diff options
Diffstat (limited to 'lisp')
566 files changed, 17979 insertions, 13795 deletions
diff --git a/lisp/ChangeLog.2 b/lisp/ChangeLog.2 index 1b0ed4206bb..a5a654ac27f 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 8bdb6baf88c..0374e1ba772 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 566e9b7cd12..3a684212743 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 f534b6e165c..27cbe10a8ae 100644 --- a/lisp/ChangeLog.7 +++ b/lisp/ChangeLog.7 @@ -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 d4709bd79d4..19b01802268 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 @@ -319,7 +323,7 @@ compile-targets: $(TARGETS) compile-main: gen-lisp compile-clean @(cd $(lisp) && \ els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \ - for el in $$els; do \ + for el in ${MAIN_FIRST} $$els; do \ test -f $$el || continue; \ test ! -f $${el}c && GREP_OPTIONS= grep '^;.*no-byte-compile: t' $$el > /dev/null && continue; \ echo "$${el}c"; \ diff --git a/lisp/abbrev.el b/lisp/abbrev.el index 734cefbb7be..fd2f36e1980 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -68,6 +68,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 +77,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." @@ -908,8 +908,14 @@ Presumes that `standard-output' points to `current-buffer'." (prin1 (symbol-value sym)) (insert " ") (prin1 (symbol-function sym)) - (insert " ") + (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) diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el index a53776d62a6..71b1b390089 100644 --- a/lisp/allout-widgets.el +++ b/lisp/allout-widgets.el @@ -768,8 +768,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) diff --git a/lisp/allout.el b/lisp/allout.el index 33317e89dee..26e7f6b56c2 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -1506,41 +1506,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 +1652,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 () diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el index 87b15ba4d31..6fb7acf600f 100644 --- a/lisp/ansi-color.el +++ b/lisp/ansi-color.el @@ -182,7 +182,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.") @@ -480,6 +480,7 @@ Emacs requires OBJECT to be a buffer." ;; 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 'evaporate t) (overlay-put overlay 'modification-hooks '(ansi-color-freeze-overlay)) (overlay-put overlay 'insert-behind-hooks '(ansi-color-freeze-overlay)) overlay))) diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 3973e97d626..4ddb29dcbb5 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -748,8 +748,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 +806,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) @@ -1011,8 +1010,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 +1061,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) @@ -2043,13 +2042,13 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (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 + (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)) diff --git a/lisp/auth-source-pass.el b/lisp/auth-source-pass.el index d783b26b4e3..cebe8c26665 100644 --- a/lisp/auth-source-pass.el +++ b/lisp/auth-source-pass.el @@ -4,10 +4,10 @@ ;; Author: Damien Cassou <damien@cassou.me>, ;; Nicolas Petton <nicolas@petton.fr> -;; Version: 2.0.0 -;; Package-Requires: ((emacs "24.4") +;; Version: 4.0.1 +;; 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. @@ -45,14 +45,22 @@ 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 + (list (auth-source-pass--build-result host port user))))) (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))) + (let ((entry (auth-source-pass--find-match host user port))) (when entry (let ((retval (list :host host @@ -73,7 +81,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,7 +92,9 @@ 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)) (defun auth-source-pass-get (key entry) @@ -139,30 +149,10 @@ 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) @@ -230,24 +220,39 @@ matching USER." (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." +(defun auth-source-pass--find-match (host user port) + "Return a password-store entry name 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." + (let* ((url (url-generic-parse-url (if (string-match-p ".*://" host) + host + (format "https://%s" host))))) + (auth-source-pass--find-match-unambiguous + (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 a password-store entry name 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." (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) + (and user port (auth-source-pass--find-one-by-entry-name (format "%s@%s:%s" user hostname port) user)) + (and user (auth-source-pass--find-one-by-entry-name (format "%s@%s" user hostname) user)) + (and port (auth-source-pass--find-one-by-entry-name (format "%s:%s" hostname port) nil)) + (auth-source-pass--find-one-by-entry-name hostname user) ;; if that didn't work, remove subdomain: foo.bar.com -> bar.com - (let ((components (split-string host "\\."))) + (let ((components (split-string hostname "\\."))) (when (= (length components) 3) ;; start from scratch - (auth-source-pass--find-match (mapconcat 'identity (cdr components) ".") user))))) + (auth-source-pass--find-match-unambiguous + (mapconcat 'identity (cdr components) ".") + user + port))))) (provide 'auth-source-pass) ;;; auth-source-pass.el ends here diff --git a/lisp/auth-source.el b/lisp/auth-source.el index b733054ae5f..abff0def95f 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)) @@ -241,7 +242,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") @@ -380,24 +381,39 @@ 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) @@ -984,12 +1000,13 @@ Note that the MAX parameter is used so we can exit the parse early." (defun auth-source-netrc-parse-next-interesting () "Advance to the next interesting position in the current buffer." + (skip-chars-forward "\t ") ;; If we're looking at a comment or are at the end of the line, move forward - (while (or (looking-at "#") + (while (or (eq (char-after) ?#) (and (eolp) (not (eobp)))) - (forward-line 1)) - (skip-chars-forward "\t ")) + (forward-line 1) + (skip-chars-forward "\t "))) (defun auth-source-netrc-parse-one () "Read one thing from the current buffer." @@ -999,8 +1016,9 @@ Note that the MAX parameter is used so we can exit the parse early." (looking-at "\"\\([^\"]*\\)\"") (looking-at "\\([^ \t\n]+\\)")) (forward-char (length (match-string 0))) - (auth-source-netrc-parse-next-interesting) - (match-string-no-properties 1))) + (prog1 + (match-string-no-properties 1) + (auth-source-netrc-parse-next-interesting)))) ;; with thanks to org-mode (defsubst auth-source-current-line (&optional pos) @@ -1300,9 +1318,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 @@ -1483,13 +1499,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 @@ -1500,9 +1516,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") @@ -1562,12 +1575,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 @@ -1968,6 +2173,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/autoinsert.el b/lisp/autoinsert.el index dfa5b603068..7858041440d 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -141,14 +141,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 +211,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 +219,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" diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 7b8302695fa..0a9d3bef546 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -373,7 +373,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 @@ -486,7 +486,7 @@ specifies in the mode line." (auto-revert-buffers) (dolist (buf (buffer-list)) (with-current-buffer buf - (when auto-revert-use-notify + (when auto-revert-notify-watch-descriptor (auto-revert-notify-rm-watch)))))) (defun auto-revert-set-timer () @@ -524,38 +524,31 @@ will use an up-to-date value of `auto-revert-interval'" (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) + ;; `auto-revert-notify-watch-descriptor' are non-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))) + (setq auto-revert-notify-watch-descriptor + (ignore-errors + (if buffer-file-name (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))))) + (expand-file-name buffer-file-name default-directory) + '(change attribute-change) + 'auto-revert-notify-handler) + (file-notify-add-watch + (expand-file-name default-directory) + '(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-notify-watch-descriptor-hash-list)) + auto-revert-notify-watch-descriptor-hash-list) + (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 @@ -611,8 +604,7 @@ no more reverts are possible until the next call of (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)))) + (auto-revert-notify-rm-watch)))) ;; Loop over all buffers, in order to find the intended one. (cl-dolist (buffer buffers) @@ -651,11 +643,9 @@ no more reverts are possible until the next call of "Check if auto-revert is active (in current buffer or globally)." (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))))) + (and global-auto-revert-mode + (not global-auto-revert-ignore-buffer) + (not (memq major-mode global-auto-revert-ignore-modes))))) (defun auto-revert-handler () "Revert current buffer, if appropriate. @@ -669,7 +659,7 @@ 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) @@ -719,7 +709,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)) @@ -813,7 +804,8 @@ the timer when no buffers need to be checked." ;; Check if we should cancel the timer. (when (and (not global-auto-revert-mode) (null auto-revert-buffer-list)) - (cancel-timer auto-revert-timer) + (if (timerp auto-revert-timer) + (cancel-timer auto-revert-timer)) (setq auto-revert-timer nil))))) diff --git a/lisp/bindings.el b/lisp/bindings.el index 3e202b9b78c..9797052725a 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) " " "-")) @@ -699,7 +743,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) diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 1a2ec1eb667..78f3e324034 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -2251,8 +2251,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/calendar/appt.el b/lisp/calendar/appt.el index 5841cb6a3a3..0259dd1e1e5 100644 --- a/lisp/calendar/appt.el +++ b/lisp/calendar/appt.el @@ -1,4 +1,4 @@ -;;; appt.el --- appointment notification functions +;;; appt.el --- appointment notification functions -*- lexical-binding:t -*- ;; Copyright (C) 1989-1990, 1994, 1998, 2001-2018 Free Software ;; Foundation, Inc. @@ -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")))))))) @@ -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 @@ -701,7 +699,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 +707,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-dst.el b/lisp/calendar/cal-dst.el index 508ae2c995f..00a8e7498af 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -1,4 +1,4 @@ -;;; 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-2018 Free Software Foundation, Inc. @@ -220,29 +220,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 @@ -279,14 +280,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 (nth 7 (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. @@ -405,7 +403,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 +415,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 +425,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-tex.el b/lisp/calendar/cal-tex.el index 552832b4834..7ae0ecb7670 100644 --- a/lisp/calendar/cal-tex.el +++ b/lisp/calendar/cal-tex.el @@ -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/calendar.el b/lisp/calendar/calendar.el index 85a5fc0c2bb..71fb76ce213 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1,4 +1,4 @@ -;;; calendar.el --- calendar functions +;;; calendar.el --- calendar functions -*- lexical-binding:t -*- ;; Copyright (C) 1988-1995, 1997, 2000-2018 Free Software Foundation, ;; Inc. @@ -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) @@ -371,7 +402,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 +496,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 +507,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 +516,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 +536,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 +549,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 +573,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 +745,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 +970,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 +1135,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 +1387,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 +1489,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 +1506,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 +1517,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 +1528,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 +1789,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 +1821,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 () @@ -2033,11 +2066,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 +2288,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 +2310,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 +2349,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 +2452,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 +2524,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 +2634,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." diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index 9f2a3334efd..acf4b20d779 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -1,4 +1,4 @@ -;;; diary-lib.el --- diary functions +;;; diary-lib.el --- diary functions -*- lexical-binding:t -*- ;; Copyright (C) 1989-1990, 1992-1995, 2001-2018 Free Software ;; Foundation, Inc. @@ -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) @@ -1406,30 +1424,30 @@ marks. This is intended to deal with deleted diary entries." (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 +1550,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 +1669,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 +1832,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 +1842,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 +1871,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 +1890,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 +1969,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 +1994,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 +2006,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 +2028,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 +2049,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) @@ -2224,18 +2247,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 +2336,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 +2369,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 +2383,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 +2416,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 4ba49a9acb1..f38308378d6 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el @@ -522,7 +522,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)) diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index a725a4e916b..c1a3e0a4213 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 @@ -996,9 +996,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.") @@ -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) @@ -1763,8 +1760,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 +1972,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 +2008,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 +2024,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 +2060,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 +2158,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 +2168,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 +2193,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 +2211,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 +2461,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 +2470,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 +2490,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 @@ -2513,21 +2505,21 @@ the entry." (setq non-marking (y-or-n-p (format "Make appointment non-marking? ")))) (save-window-excursion - (unless diary-file - (setq diary-file + (unless diary-filename + (setq diary-filename (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))) + string non-marking diary-filename))) ;; Würgaround to remove the trailing blank char - (with-current-buffer (find-file diary-file) + (with-current-buffer (find-file diary-filename) (goto-char (point-max)) (if (= (char-before) ? ) (delete-char -1))) - ;; return diary-file in case it has been changed interactively - diary-file) + ;; return diary-filename in case it has been changed interactively + diary-filename) ;; ====================================================================== ;; Examples diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el index 1e1656cd319..ddaf7451bd9 100644 --- a/lisp/calendar/solar.el +++ b/lisp/calendar/solar.el @@ -1,4 +1,4 @@ -;;; solar.el --- calendar functions for solar events +;;; solar.el --- calendar functions for solar events -*- lexical-binding:t -*- ;; Copyright (C) 1992-1993, 1995, 1997, 2001-2018 Free Software ;; Foundation, Inc. @@ -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/timeclock.el b/lisp/calendar/timeclock.el index 3b96d427023..b46e7732fd3 100644 --- a/lisp/calendar/timeclock.el +++ b/lisp/calendar/timeclock.el @@ -144,6 +144,9 @@ This variable only has effect if set with \\[customize]." (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) @@ -271,8 +274,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 diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index c1c8e196eaf..5161ae8d668 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.") @@ -2274,8 +2266,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)) @@ -2416,7 +2408,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 @@ -4613,12 +4613,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))))) @@ -5990,8 +5991,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 diff --git a/lisp/cedet/cedet.el b/lisp/cedet/cedet.el index 216b0edeb69..34a4d992762 100644 --- a/lisp/cedet/cedet.el +++ b/lisp/cedet/cedet.el @@ -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/ede.el b/lisp/cedet/ede.el index 76acf8a9418..5bbc2d0f850 100644 --- a/lisp/cedet/ede.el +++ b/lisp/cedet/ede.el @@ -1095,6 +1095,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/detect.el b/lisp/cedet/ede/detect.el index 5b708ae436e..2b5086a1c5a 100644 --- a/lisp/cedet/ede/detect.el +++ b/lisp/cedet/ede/detect.el @@ -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)) + (float-time (time-subtract nil start)) (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 4c21cf44ef6..33afc7e5473 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) diff --git a/lisp/cedet/ede/linux.el b/lisp/cedet/ede/linux.el index 862a9e597aa..cb5e739717d 100644 --- a/lisp/cedet/ede/linux.el +++ b/lisp/cedet/ede/linux.el @@ -32,10 +32,9 @@ ;; * Add texinfo lookup options. ;; * Add website -(eval-when-compile (require 'cl)) - (require 'ede) (require 'ede/make) +(eval-when-compile (require 'cl-lib)) (declare-function semanticdb-file-table-object "semantic/db") (declare-function semanticdb-needs-refresh-p "semantic/db") @@ -116,7 +115,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 +164,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 +175,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/pmake.el b/lisp/cedet/ede/pmake.el index 22aa25a4a73..f0f07e9043f 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 ad2355a8512..553f918f9ec 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 091ea1741b7..f75006d6c57 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 3d390bda46d..fc7205f940d 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 2ef91e767bb..d9b8989ec74 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 849ef14352b..992996a9355 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 d85300c3123..d1a8fce78f1 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 a34d209375b..c6c52ed474e 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 ce1978c618f..215b7914a52 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 5d6ca95d7c5..75d02eccbcb 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/simple.el b/lisp/cedet/ede/simple.el index b945d690f95..3931cf63483 100644 --- a/lisp/cedet/ede/simple.el +++ b/lisp/cedet/ede/simple.el @@ -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 b616af3a430..71a1c38a522 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 99fe4a5562c..353bec23575 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) diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el index 7f175f2d57e..1cd306b89b9 100644 --- a/lisp/cedet/mode-local.el +++ b/lisp/cedet/mode-local.el @@ -46,8 +46,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 diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el index a3fa80a6948..e34b51f3521 100644 --- a/lisp/cedet/pulse.el +++ b/lisp/cedet/pulse.el @@ -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 4b2f5d2209a..b24e2fbbb1b 100644 --- a/lisp/cedet/semantic.el +++ b/lisp/cedet/semantic.el @@ -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*") diff --git a/lisp/cedet/semantic/analyze.el b/lisp/cedet/semantic/analyze.el index 1abf785834b..2c50722813d 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) @@ -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 diff --git a/lisp/cedet/semantic/analyze/refs.el b/lisp/cedet/semantic/analyze/refs.el index d4da9e3170e..6268da80650 100644 --- a/lisp/cedet/semantic/analyze/refs.el +++ b/lisp/cedet/semantic/analyze/refs.el @@ -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) diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el index 73c8a56dbd8..cb27582fa54 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))) diff --git a/lisp/cedet/semantic/bovine/debug.el b/lisp/cedet/semantic/bovine/debug.el index 9bacee2a9cc..e511b3d2710 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/grammar.el b/lisp/cedet/semantic/bovine/grammar.el index 0eab01b58b1..1746f3e6ff5 100644 --- a/lisp/cedet/semantic/bovine/grammar.el +++ b/lisp/cedet/semantic/bovine/grammar.el @@ -475,6 +475,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 +510,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/complete.el b/lisp/cedet/semantic/complete.el index 1da1a319f11..eb25f114279 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -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) @@ -1890,8 +1889,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-displayor-traditional-with-focus-highlight) + ;;(semantic-displayor-tooltip) prompt default-tag initial-input @@ -1912,8 +1911,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-displayor-traditional-with-focus-highlight) + ;;(semantic-displayor-tooltip) prompt default-tag initial-input @@ -1937,7 +1936,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-displayor-traditional-with-focus-highlight) prompt default-tag initial-input @@ -1954,7 +1953,6 @@ 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 +1982,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-displayor-class) + ;;(semantic-displayor-tooltip) (current-buffer) start end)) ))) @@ -2013,7 +2010,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-displayor-traditional-with-focus-highlight) (with-current-buffer (oref context buffer) (goto-char (cdr (oref context bounds))) (concat prompt (mapconcat 'identity syms ".") @@ -2037,7 +2034,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,9 +2060,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-displayor-class) + ;;(semantic-displayor-tooltip) (oref context buffer) (car (oref context bounds)) (cdr (oref context bounds)) diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el index d3ad5c75376..7cb2ac1e94d 100644 --- a/lisp/cedet/semantic/db-find.el +++ b/lisp/cedet/semantic/db-find.el @@ -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-javascript.el b/lisp/cedet/semantic/db-javascript.el index c58c295cd5c..789614d511a 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 8a136132b7e..e6a2340b8c2 100644 --- a/lisp/cedet/semantic/db-mode.el +++ b/lisp/cedet/semantic/db-mode.el @@ -50,6 +50,9 @@ (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. @@ -67,8 +70,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") diff --git a/lisp/cedet/semantic/db-ref.el b/lisp/cedet/semantic/db-ref.el index 8f20fee9545..7713a3cec53 100644 --- a/lisp/cedet/semantic/db-ref.el +++ b/lisp/cedet/semantic/db-ref.el @@ -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/debug.el b/lisp/cedet/semantic/debug.el index d127b6465fe..3c71c209576 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) @@ -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/mode.el b/lisp/cedet/semantic/decorate/mode.el index ea3d63d21bc..100e221ce31 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) @@ -82,13 +82,13 @@ add items to this list." (defsubst semantic-decoration-set-property (deco property value) "Set the DECO decoration's PROPERTY to VALUE. Return DECO." - (assert (semantic-decoration-p deco)) + (cl-assert (semantic-decoration-p deco)) (semantic-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)) + (cl-assert (semantic-decoration-p deco)) (semantic-overlay-get deco property)) (defsubst semantic-decoration-set-face (deco 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,7 +113,7 @@ 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)) + (cl-assert (semantic-decoration-p deco)) (semantic-overlay-move deco begin end) 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 diff --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el index 617ad7867f5..8c36623b72f 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/lex.el b/lisp/cedet/semantic/lex.el index 81dfc055f2c..0cc296f09da 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -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) @@ -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 bc8b1a9ef27..ad630148909 100644 --- a/lisp/cedet/semantic/mru-bookmark.el +++ b/lisp/cedet/semantic/mru-bookmark.el @@ -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.") diff --git a/lisp/cedet/semantic/sb.el b/lisp/cedet/semantic/sb.el index 739f6742146..443c3839bb7 100644 --- a/lisp/cedet/semantic/sb.el +++ b/lisp/cedet/semantic/sb.el @@ -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))) diff --git a/lisp/cedet/semantic/scope.el b/lisp/cedet/semantic/scope.el index a2c68ed3a63..e653d0a03dc 100644 --- a/lisp/cedet/semantic/scope.el +++ b/lisp/cedet/semantic/scope.el @@ -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/symref/filter.el b/lisp/cedet/semantic/symref/filter.el index 0e8ac6392c8..726ef590742 100644 --- a/lisp/cedet/semantic/symref/filter.el +++ b/lisp/cedet/semantic/symref/filter.el @@ -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/list.el b/lisp/cedet/semantic/symref/list.el index 1be2b0ed393..ab22d0d00a0 100644 --- a/lisp/cedet/semantic/symref/list.el +++ b/lisp/cedet/semantic/symref/list.el @@ -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) @@ -193,11 +193,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'." diff --git a/lisp/cedet/semantic/texi.el b/lisp/cedet/semantic/texi.el index 9769ae89289..1fdfd104a5e 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 diff --git a/lisp/cedet/semantic/util.el b/lisp/cedet/semantic/util.el index 313f2350a43..0a02b898e34 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 @@ -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 @@ -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/comp.el b/lisp/cedet/semantic/wisent/comp.el index 1902006ee5b..837222ad4b1 100644 --- a/lisp/cedet/semantic/wisent/comp.el +++ b/lisp/cedet/semantic/wisent/comp.el @@ -41,7 +41,7 @@ ;;; Code: (require 'semantic/wisent) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;;; ------------------- ;;;; Misc. useful things @@ -2906,7 +2906,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 +2926,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/python.el b/lisp/cedet/semantic/wisent/python.el index db2d7c96083..f7944fe539b 100644 --- a/lisp/cedet/semantic/wisent/python.el +++ b/lisp/cedet/semantic/wisent/python.el @@ -41,9 +41,6 @@ (require 'semantic/ctxt) (require 'semantic/format) -(eval-when-compile - (require 'cl)) - ;;; Customization ;; @@ -358,7 +355,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/srecode/compile.el b/lisp/cedet/srecode/compile.el index 69282c1a0dd..a0a53a6473a 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) diff --git a/lisp/cedet/srecode/dictionary.el b/lisp/cedet/srecode/dictionary.el index 4a84693fe7e..a2410becb02 100644 --- a/lisp/cedet/srecode/dictionary.el +++ b/lisp/cedet/srecode/dictionary.el @@ -28,7 +28,6 @@ ;;; CLASSES -(eval-when-compile (require 'cl)) (require 'eieio) (require 'cl-generic) (require 'srecode) @@ -612,10 +611,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 "*"))) diff --git a/lisp/cedet/srecode/extract.el b/lisp/cedet/srecode/extract.el index 3e2c4ebd12c..276f2ace2f1 100644 --- a/lisp/cedet/srecode/extract.el +++ b/lisp/cedet/srecode/extract.el @@ -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) diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el index 7c9424945f0..1d419c93ba7 100644 --- a/lisp/cedet/srecode/map.el +++ b/lisp/cedet/srecode/map.el @@ -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/srt-mode.el b/lisp/cedet/srecode/srt-mode.el index ef1d9e37c05..6c269e0d914 100644 --- a/lisp/cedet/srecode/srt-mode.el +++ b/lisp/cedet/srecode/srt-mode.el @@ -494,7 +494,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) @@ -605,7 +605,6 @@ section or ? for an ask variable." (setq context-return (semantic-analyze-context-functionarg - "context-for-srecode" :buffer (current-buffer) :scope scope :bounds bounds diff --git a/lisp/cedet/srecode/srt.el b/lisp/cedet/srecode/srt.el index 3bae20e3554..fdabdc4c8ed 100644 --- a/lisp/cedet/srecode/srt.el +++ b/lisp/cedet/srecode/srt.el @@ -25,7 +25,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'eieio) (require 'srecode/dictionary) (require 'srecode/insert) diff --git a/lisp/chistory.el b/lisp/chistory.el index d557c9f4eee..b4a8b6e72f9 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 122291bcf9c..f334a4ca4d4 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -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 @@ -364,10 +364,10 @@ This variable is buffer-local." "\\(?:" (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:]]+ .+\\)?[\\s ]*[:：៖][\\s ]*\\'") "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 +429,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. @@ -1434,24 +1431,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 +1477,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." @@ -2281,8 +2288,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. diff --git a/lisp/completion.el b/lisp/completion.el index a5c8158d1b3..2ddf0999e43 100644 --- a/lisp/completion.el +++ b/lisp/completion.el @@ -518,6 +518,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) @@ -2225,7 +2228,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 @@ -2357,8 +2363,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/cus-edit.el b/lisp/cus-edit.el index 3ede483dade..a12897e7997 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -986,7 +986,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) @@ -2431,6 +2431,18 @@ 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)) :foreground "light blue" :weight bold) @@ -2456,8 +2468,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 +2478,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,7 +2576,8 @@ 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 @@ -2581,7 +2609,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 +2669,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 +3354,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 +3394,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 +3790,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 diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 451e7f762f4..f31d1df3097 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -414,6 +414,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 +434,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) @@ -706,13 +710,15 @@ since it could result in memory overflow and make Emacs crash." (put symbol 'risky-local-variable (cadr prop))) (if (setq prop (memq :set rest)) (put symbol 'custom-set (cadr prop))) - ;; 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. diff --git a/lisp/delim-col.el b/lisp/delim-col.el index 5acb23922c2..076d4dc5c3d 100644 --- a/lisp/delim-col.el +++ b/lisp/delim-col.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2018 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> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Version: 2.1 ;; Keywords: internal ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre diff --git a/lisp/descr-text.el b/lisp/descr-text.el index ddd7d801d2a..d8f8188eb1e 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -835,8 +835,6 @@ relevant to POS." (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 b98319bdcf5..3e1ba200b50 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -158,8 +158,6 @@ 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). @@ -248,9 +246,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 +387,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 +489,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 +532,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) @@ -713,12 +701,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 +734,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 +803,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 +841,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) @@ -900,8 +891,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")))) @@ -1085,7 +1076,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 +1089,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 +1098,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,9 +1131,9 @@ 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). @@ -1241,12 +1232,12 @@ 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. @@ -1265,7 +1256,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 +1301,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 +1330,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 () @@ -1564,8 +1544,7 @@ and try to load that." (setq buffer-display-time (if buffer-display-time (time-add buffer-display-time - (time-subtract (current-time) - desktop-file-modtime)) + (time-subtract nil desktop-file-modtime)) (current-time))) (unless (< desktop-file-version 208) ; Don't misinterpret any old custom args (dolist (record compacted-vars) @@ -1609,7 +1588,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/dired-aux.el b/lisp/dired-aux.el index c336103f80b..821b7d79759 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -301,7 +301,7 @@ 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 @@ -361,7 +361,7 @@ 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 @@ -476,7 +476,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)) @@ -666,7 +666,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) @@ -727,7 +727,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) @@ -1030,7 +1030,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) @@ -1153,7 +1153,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 @@ -1549,6 +1549,24 @@ 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))) @@ -1565,6 +1583,7 @@ Special value `always' suppresses confirmation." (if (stringp (car attrs)) ;; It is a symlink (make-symbolic-link (car 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) @@ -1574,6 +1593,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) @@ -1826,7 +1846,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))) @@ -1844,28 +1864,31 @@ Optional arg HOW-TO determines how to treat the target. (dired-mark-read-file-name (concat (if dired-one-file op1 operation) " %s 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)) @@ -2747,7 +2770,9 @@ Intended to be added to `isearch-mode-hook'." "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. @@ -2760,15 +2785,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. @@ -2778,14 +2803,14 @@ 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))) ;;;###autoload (defun dired-do-search (regexp) @@ -2806,7 +2831,7 @@ 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)) @@ -2830,7 +2855,7 @@ REGEXP should use constructs supported by your local `grep' command." (require 'grep) (defvar grep-find-ignored-files) (defvar grep-find-ignored-directories) - (let* ((files (dired-get-marked-files)) + (let* ((files (dired-get-marked-files nil nil nil nil t)) (ignores (nconc (mapcar (lambda (s) (concat s "/")) grep-find-ignored-directories) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index a90f1f4adcd..4517dedeeb4 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -137,8 +137,6 @@ 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 @@ -194,21 +192,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 +315,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)) @@ -787,34 +769,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 +785,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 +1210,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. diff --git a/lisp/dired.el b/lisp/dired.el index c421e51ffd1..1348df6934b 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -198,8 +198,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 @@ -643,7 +645,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. @@ -660,7 +662,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 @@ -670,13 +675,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 @@ -841,14 +850,18 @@ If DIRNAME is already in a Dired buffer, that buffer is used without refresh." (not (eq (car attributes) t)) (equal (nth 5 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'. @@ -1430,7 +1443,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) @@ -2343,12 +2357,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 @@ -2995,37 +3004,6 @@ Any other value means to ask for each directory." ;; Match anything but `.' and `..'. (defvar dired-re-no-dot "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*") -(defconst dired-delete-help - "Type: -`yes' to delete recursively the current directory, -`no' to skip to next, -`all' to delete all remaining directories with no more questions, -`quit' to exit, -`help' to show this help message.") - -(defun dired--yes-no-all-quit-help (prompt &optional help-msg) - "Ask a question with valid answers: yes, no, all, quit, help. -PROMPT must end with '? ', for instance, 'Delete it? '. -If optional arg HELP-MSG is non-nil, then is a message to show when -the user answers 'help'. Otherwise, default to `dired-delete-help'." - (let ((valid-answers (list "yes" "no" "all" "quit")) - (answer "") - (input-fn (lambda () - (read-string - (format "%s [yes, no, all, quit, help] " prompt))))) - (setq answer (funcall input-fn)) - (when (string= answer "help") - (with-help-window "*Help*" - (with-current-buffer "*Help*" - (insert (or help-msg dired-delete-help))))) - (while (not (member answer valid-answers)) - (unless (string= answer "help") - (beep) - (message "Please answer `yes' or `no' or `all' or `quit'") - (sleep-for 2)) - (setq answer (funcall input-fn))) - answer)) - ;; Delete file, possibly delete a directory and all its files. ;; This function is useful outside of dired. One could change its name ;; to e.g. recursive-delete-file and put it somewhere else. @@ -3055,11 +3033,17 @@ TRASH non-nil means to trash the file instead of deleting, provided "trash" "delete") (dired-make-relative file)))) - (pcase (dired--yes-no-all-quit-help prompt) ; Prompt user. + (pcase (read-answer + prompt + '(("yes" ?y "delete recursively the current directory") + ("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))))) + ('"quit" (keyboard-quit)) + (_ (keyboard-quit))))) ; catch all unknown answers (setq recursive nil)) ; Empty dir or recursive is nil. (delete-directory file recursive trash)))) @@ -3117,7 +3101,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 " diff --git a/lisp/dom.el b/lisp/dom.el index 8750d7fa866..6045a68d14c 100644 --- a/lisp/dom.el +++ b/lisp/dom.el @@ -78,15 +78,21 @@ 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 + 'identity + (mapcar + (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 87f7ed10fea..ebb8acb8608 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) diff --git a/lisp/ecomplete.el b/lisp/ecomplete.el index 43ab8e691e6..3bfab4743cb 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-2018 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. @@ -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) (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/electric.el b/lisp/electric.el index c146b3ceaeb..c00e7c00a59 100644 --- a/lisp/electric.el +++ b/lisp/electric.el @@ -451,6 +451,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 +469,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 +500,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,13 +521,19 @@ 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>)))))))))) + (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) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 17272328302..49c2d5f4f9f 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))) diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 92ad6155b53..c458e7b1cb6 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -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))))))) @@ -605,7 +607,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 @@ -1143,9 +1146,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/benchmark.el b/lisp/emacs-lisp/benchmark.el index d74446c7479..e062a1867a8 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -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-subtract nil ,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,7 +74,7 @@ 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")) @@ -86,7 +84,7 @@ result. The overhead of the `lambda's is accounted for." (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/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c90509d131b..3bc4c438d6a 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -656,15 +656,15 @@ ((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 +678,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 +839,24 @@ (if (= 1 (length (cdr form))) "" "s")) 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))) + (put 'identity 'byte-optimizer 'byte-optimize-identity) +(put 'memq 'byte-optimizer 'byte-optimize-memq) (put '+ 'byte-optimizer 'byte-optimize-plus) (put '* 'byte-optimizer 'byte-optimize-multiply) @@ -911,11 +875,10 @@ (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) @@ -923,9 +886,9 @@ (put 'string< 'byte-optimizer 'byte-optimize-predicate) (put 'string-lessp '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,7 +896,6 @@ (put 'car-safe 'byte-optimizer 'byte-optimize-predicate) (put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate) - ;; I'm not convinced that this is necessary. Doesn't the optimizer loop ;; take care of this? - Jamie ;; I think this may some times be necessary to reduce ie (quote 5) to 5, @@ -967,8 +929,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 +946,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))) @@ -1186,6 +1146,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 +1160,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 +1172,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 @@ -1240,7 +1202,6 @@ 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 get-largest-window get-lru-window @@ -1248,9 +1209,9 @@ 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 +1236,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))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index d1119e10903..ad6b5b7ce21 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -124,17 +124,10 @@ (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")) +;; 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. @@ -1938,17 +1931,7 @@ The value is non-nil if there were no errors, nil if errors." ;; parallel bootstrap), it does not risk getting a ;; half-finished file. (Bug#4196) (tempfile - (if (file-name-absolute-p target-file) - (make-temp-file target-file) - ;; If target-file is relative and includes - ;; leading directories, make-temp-file will - ;; assume those leading directories exist - ;; under temporary-file-directory, which might - ;; not be true. So strip leading directories - ;; from relative file names before calling - ;; make-temp-file. - (make-temp-file - (file-name-nondirectory target-file)))) + (make-temp-file (expand-file-name target-file))) (default-modes (default-file-modes)) (temp-modes (logand default-modes #o600)) (desired-modes (logand default-modes #o666)) @@ -2079,14 +2062,8 @@ 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) + (let* ((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!" @@ -2449,6 +2426,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 @@ -2508,6 +2495,12 @@ list that represents a doc string reference. (mapc 'byte-compile-file-form (cdr 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) @@ -2754,15 +2747,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)) @@ -2855,9 +2845,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))))) @@ -3128,7 +3119,13 @@ 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) interactive-only) @@ -3585,7 +3582,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))))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 02fe794467b..ca46dbb7b55 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -449,8 +449,11 @@ places where they originally did not directly appear." ;defconst, defvar (`(,(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) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 4e8ecba4a15..300a3908c14 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -171,6 +171,7 @@ (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 @@ -436,23 +437,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 +459,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 +575,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 +610,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 +642,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 +654,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 +663,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 +678,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 +706,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.") @@ -1147,6 +1130,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). @@ -1155,7 +1147,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) @@ -1171,27 +1163,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 ;; @@ -1342,7 +1314,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. @@ -1471,9 +1443,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 "[.!?]") @@ -1796,7 +1768,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)) @@ -2593,12 +2565,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) @@ -2615,9 +2587,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-generic.el b/lisp/emacs-lisp/cl-generic.el index c6996bfc15b..173173305b4 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -808,22 +808,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))))) @@ -1156,45 +1160,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 +1183,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-macs.el b/lisp/emacs-lisp/cl-macs.el index 9c47ceae18e..d7e4b4e611a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -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))) @@ -884,7 +894,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 +963,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 +998,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 +1336,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 +1357,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 +1368,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 +1525,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--"))) @@ -2057,23 +2091,15 @@ 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. @@ -2082,7 +2108,7 @@ except that it additionally expands symbol macros." (setq exp (cadr symval))))) (`(setq . ,_) ;; Convert setq to setf if required by symbol-macro expansion. - (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env)) + (let* ((args (mapcar (lambda (f) (macroexpand f env)) (cdr exp))) (p args)) (while (and p (symbolp (car p))) (setq p (cddr p))) @@ -2090,60 +2116,102 @@ except that it additionally expands symbol macros." (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. + ;; 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)) @@ -2155,16 +2223,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 @@ -2176,7 +2246,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. @@ -2427,10 +2498,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)) @@ -2457,7 +2529,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))) @@ -2647,6 +2721,9 @@ non-nil value, that slot cannot be set via `setf'. (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))) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 4e73a4a31b7..2a70f9b9248 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 66561ce2644..1eae8faf236 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -298,12 +298,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) diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 69c5ebd45d6..2f29c196964 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -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 5aa856f467c..3ec0bd81cf4 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/debug.el b/lisp/emacs-lisp/debug.el index 593fab97275..e8a3015b8fb 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -27,6 +27,7 @@ ;;; Code: +(require 'cl-lib) (require 'button) (defgroup debugger nil @@ -144,9 +145,29 @@ 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 @@ -271,8 +292,14 @@ first will be printed into the backtrace buffer." (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--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-insert-backtrace (frames do-xrefs) "Format and insert the backtrace FRAMES at point. @@ -287,10 +314,10 @@ Make functions into cross-reference buttons if DO-XREFS is non-nil." (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 "()"))) + (debugger--print fun) + (if args (debugger--print args) (princ "()"))) (t - (funcall debugger-print-function (cons fun args)) + (debugger--print (cons fun args)) (cl-incf fun-pt))) (when fun-file (make-text-button fun-pt (+ fun-pt (length (symbol-name fun))) @@ -336,7 +363,7 @@ That buffer should be current already." (insert "--returning value: ") (setq pos (point)) (setq debugger-value (nth 1 args)) - (funcall debugger-print-function debugger-value (current-buffer)) + (debugger--print debugger-value (current-buffer)) (setf (cl-getf (nth 3 (car frames)) :debug-on-exit) nil) (insert ?\n)) ;; Watchpoint triggered. @@ -361,7 +388,7 @@ That buffer should be current already." (`error (insert "--Lisp error: ") (setq pos (point)) - (funcall debugger-print-function (nth 1 args) (current-buffer)) + (debugger--print (nth 1 args) (current-buffer)) (insert ?\n)) ;; debug-on-call, when the next thing is an eval. (`t @@ -371,7 +398,7 @@ That buffer should be current already." (_ (insert ": ") (setq pos (point)) - (funcall debugger-print-function + (debugger--print (if (eq (car args) 'nil) (cdr args) args) (current-buffer)) @@ -417,7 +444,7 @@ 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) + (debugger--print debugger-value) (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. @@ -532,7 +559,7 @@ 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)))))))) @@ -554,7 +581,7 @@ The environment used is the one when entering the activation frame at point." (insert "\n ") (prin1 symbol (current-buffer)) (insert " = ") - (prin1 value (current-buffer)))))))) + (debugger--print value (current-buffer)))))))) (defun debugger--show-locals () "For the frame at point, insert locals and add text properties." diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 55fa439ad38..6b47ffea07a 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -281,25 +281,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/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 21ca69324ed..a81b6fefb20 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -545,6 +545,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)) @@ -571,6 +572,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))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 7e4d244f5e2..e759c5b5b24 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1066,6 +1066,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,47 +1151,47 @@ 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? @@ -1333,7 +1359,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 +1384,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. @@ -2181,7 +2213,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. @@ -2212,7 +2258,7 @@ error is signaled again." edebug-initial-mode edebug-execution-mode) edebug-next-execution-mode nil) - (edebug-enter function args body)))) + (edebug-default-enter function args body)))) (let* ((edebug-data (get function 'edebug)) (edebug-def-mark (car edebug-data)) ; mark at def start @@ -2331,22 +2377,27 @@ 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))) @@ -3495,14 +3546,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) diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index cba6cab1d4f..75709ddc0a8 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -360,32 +360,30 @@ Second, any text properties will be stripped from strings." proposed-value)))) ;; For hash-tables and vectors, the top-level `read' will not ;; "look inside" member values, so we need to do that - ;; explicitly. + ;; explicitly. Because `eieio-override-prin1' is recursive in + ;; the case of hash-tables and vectors, we recurse + ;; `eieio-persistent-validate/fix-slot-value' here as well. ((hash-table-p proposed-value) (maphash (lambda (key value) - (cond ((class-p (car-safe value)) - (setf (gethash key proposed-value) - (eieio-persistent-convert-list-to-object - value))) - ((and (consp value) - (eq (car value) 'quote)) - (setf (gethash key proposed-value) - (cadr value))))) + (setf (gethash key proposed-value) + (if (class-p (car-safe value)) + (eieio-persistent-convert-list-to-object + value) + (eieio-persistent-validate/fix-slot-value + class slot value)))) proposed-value) proposed-value) ((vectorp proposed-value) (dotimes (i (length proposed-value)) (let ((val (aref proposed-value i))) - (cond ((class-p (car-safe val)) - (aset proposed-value i - (eieio-persistent-convert-list-to-object - (aref proposed-value i)))) - ((and (consp val) - (eq (car val) 'quote)) - (aset proposed-value i - (cadr val)))))) + (aset proposed-value i + (if (class-p (car-safe val)) + (eieio-persistent-convert-list-to-object + val) + (eieio-persistent-validate/fix-slot-value + class slot val))))) proposed-value) ((stringp proposed-value) @@ -500,7 +498,7 @@ 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) "Set the string which is OBJ's NAME." diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index b95f7486f76..98cdd4fd903 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -377,9 +377,21 @@ 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. @@ -389,21 +401,9 @@ If EXTRA, include that in the string returned to represent the symbol." (eieio-object-name-string obj) (or 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) +(cl-defgeneric eieio-object-set-name-string (obj name) "Set the string which is OBJ's NAME." - (declare (obsolete eieio-named "25.1")) + (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ \\='object-name) NAME) instead" "25.1")) (cl-check-type name string) (setf (gethash obj eieio--object-names) name)) (define-obsolete-function-alias @@ -847,7 +847,16 @@ to prepend a space." (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. @@ -859,10 +868,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)) @@ -871,12 +881,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))) @@ -889,7 +901,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 @@ -904,7 +917,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) @@ -942,14 +955,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/elint.el b/lisp/emacs-lisp/elint.el index b89290ad524..391d3fd0af9 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) @@ -1107,7 +1095,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 +1104,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 954e7aa73ae..012e7cf1cd3 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 15d488f7101..32bb367cdb3 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -676,6 +676,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)) @@ -1230,6 +1231,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 +1339,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,16 +1358,18 @@ 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%s (%s, %f sec)%s\n" (if (not abortedp) "" "Aborted: ") @@ -1371,6 +1382,10 @@ Returns the stats object." "" (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))) @@ -1438,16 +1453,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 +1491,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) @@ -1510,7 +1530,15 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (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 "-----------------------") @@ -1530,10 +1558,23 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (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)))) @@ -2544,8 +2585,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 +2621,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 +2635,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 +2654,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 262d4d85941..52d8451f4bc 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -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..bbf4c5da7e5 --- /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-2018 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 ed8dc74506f..c5424693eca 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -368,28 +368,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 +466,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/generic.el b/lisp/emacs-lisp/generic.el index e2009bf4c26..194fa1e1c24 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -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 e210def1a0f..6bfc32c8356 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -217,6 +217,8 @@ to be pure and copyable. Example use: (declare (indent 2) (debug (&define name sexp 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! diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 94be5acd6d3..4e5b1a7e4ff 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?"))) diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 68d50e6d0b2..5a89923f8fb 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))) diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index 2a7eddedad7..61c04ff7b3e 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -191,34 +191,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)) @@ -256,4 +252,126 @@ the current %s and exit." ;; Return the number of actions that were taken. actions)) + +;; read-answer is a general-purpose question-asker that supports +;; either long or short answers. + +;; For backward compatibility check if short y/n answers are preferred. +(defcustom read-answer-short (eq (symbol-function 'yes-or-no-p) 'y-or-n-p) + "If non-nil, accept short answers to the question." + :type 'boolean + :version "27.1" + :group 'minibuffer) + +(defconst read-answer-map--memoize (make-hash-table :weakness 'key :test 'equal)) + +(defun read-answer (question answers) + "Read an answer either as a complete word or its character abbreviation. +Ask user a question and accept an answer from the list of possible answers. + +QUESTION should end in a space; this function adds a list of answers to it. + +ANSWERS is an alist with elements in the following format: + (LONG-ANSWER SHORT-ANSWER HELP-MESSAGE) +where + LONG-ANSWER is a complete answer, + SHORT-ANSWER is an abbreviated one-character answer, + HELP-MESSAGE is a string describing the meaning of the answer. + +Example: + \\='((\"yes\" ?y \"perform the action\") + (\"no\" ?n \"skip to the next\") + (\"all\" ?! \"accept all remaining without more questions\") + (\"help\" ?h \"show help\") + (\"quit\" ?q \"exit\")) + +When `read-answer-short' is non-nil, accept short answers. + +Return a long answer even in case of accepting short ones. + +When `use-dialog-box' is t, pop up a dialog window to get user input." + (custom-reevaluate-setting 'read-answer-short) + (let* ((short read-answer-short) + (answers-with-help + (if (assoc "help" answers) + answers + (append answers '(("help" ?? "show this help message"))))) + (answers-without-help + (assoc-delete-all "help" (copy-alist answers-with-help))) + (prompt + (format "%s(%s) " question + (mapconcat (lambda (a) + (if short + (format "%c" (nth 1 a)) + (nth 0 a))) + answers-with-help ", "))) + (message + (format "Please answer %s." + (mapconcat (lambda (a) + (format "`%s'" (if short + (string (nth 1 a)) + (nth 0 a)))) + answers-with-help " or "))) + (short-answer-map + (when short + (or (gethash answers read-answer-map--memoize) + (puthash answers + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (dolist (a answers-with-help) + (define-key map (vector (nth 1 a)) + (lambda () + (interactive) + (delete-minibuffer-contents) + (insert (nth 0 a)) + (exit-minibuffer)))) + (define-key map [remap self-insert-command] + (lambda () + (interactive) + (delete-minibuffer-contents) + (beep) + (message message) + (sleep-for 2))) + map) + read-answer-map--memoize)))) + answer) + (while (not (assoc (setq answer (downcase + (cond + ((and (display-popup-menus-p) + last-input-event ; not during startup + (listp last-nonmenu-event) + use-dialog-box) + (x-popup-dialog + t + (cons question + (mapcar (lambda (a) + (cons (capitalize (nth 0 a)) + (nth 0 a))) + answers-with-help)))) + (short + (read-from-minibuffer + prompt nil short-answer-map nil + 'yes-or-no-p-history)) + (t + (read-from-minibuffer + prompt nil nil nil + 'yes-or-no-p-history))))) + answers-without-help)) + (if (string= answer "help") + (with-help-window "*Help*" + (with-current-buffer "*Help*" + (insert "Type:\n" + (mapconcat + (lambda (a) + (format "`%s'%s to %s" + (if short (string (nth 1 a)) (nth 0 a)) + (if short (format " (%s)" (nth 0 a)) "") + (nth 2 a))) + answers-with-help ",\n") + ".\n"))) + (beep) + (message message) + (sleep-for 2))) + answer)) + ;;; map-ynp.el ends here diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index e20cc6570db..76a9095e4ae 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -41,13 +41,13 @@ '((: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. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c56502236ee..94d98178c4d 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,8 +143,8 @@ ;;; 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) @@ -161,29 +161,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") @@ -676,6 +681,9 @@ 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 @@ -718,7 +726,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. @@ -961,17 +972,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. @@ -1436,45 +1442,61 @@ 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) + (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)) + (unless package--initialized + (package-initialize t)) (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) - ;; This uses `package--mapc' so it must be called after - ;; `package--initialized' is t. - (package--build-compatibility-table)) - + (error (message "%s" (error-message-string err))))))) ;;;; Populating `package-archive-contents' from archives ;; This subsection populates the variables listed above from the @@ -1856,18 +1878,26 @@ 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)) + ((not package--initialized) (error "package.el is not yet initialized!")) + (t (or (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. @@ -1877,64 +1907,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. @@ -1976,7 +1948,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) @@ -2148,7 +2122,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) @@ -3473,6 +3449,97 @@ The list is displayed in a buffer named `*Packages*'." (interactive) (list-packages t)) +;;;; 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 +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +")))) + (provide 'package) ;;; package.el ends here diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el index d76bf024d0a..2491ccea95b 100644 --- a/lisp/emacs-lisp/radix-tree.el +++ b/lisp/emacs-lisp/radix-tree.el @@ -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/rx.el b/lisp/emacs-lisp/rx.el index 30bb129e8f2..85e74f28ef0 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -106,6 +106,8 @@ ;;; Code: +(require 'cl-lib) + ;; FIXME: support macros. (defvar rx-constituents ;Not `const' because some modes extend it. diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 1788f0d71f7..2e53382fa87 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. diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index 9c293117c62..21bc2ce6d43 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -39,464 +39,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 "\r 2\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 +565,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 +589,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 +603,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 +671,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/testcover.el b/lisp/emacs-lisp/testcover.el index dff990ea401..d48c79cd770 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -33,7 +33,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 +49,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 +63,7 @@ ;; error if these "potentially" 1-valued forms actually return differing ;; values. +(eval-when-compile (require 'cl-lib)) (require 'edebug) (provide 'testcover) @@ -89,16 +91,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 +111,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 +186,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 +208,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 +224,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 '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 'unknown old-result) + (aset testcover-vector after-index (testcover--copy-object value))) + ((eq 'maybe old-result) + (aset testcover-vector after-index '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 '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 +357,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 '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 '(unknown maybe 1value)) 'testcover-nohits 'testcover-1value)))) (set-buffer-modified-p changed)))) @@ -553,4 +394,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 `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 '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..b4644024583 --- /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 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 f12633e6de1..823d4960aa0 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,12 +41,19 @@ ;; 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)) + (cl-assert lexical-binding) (let ((forced (make-symbol "forced")) (val (make-symbol "val"))) `(let (,forced ,val) @@ -68,5 +75,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.el b/lisp/emacs-lisp/timer.el index b1e12b1fd56..795554fec58 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -141,20 +141,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) diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index f6b569bc7fe..03f22ebf1a1 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -93,7 +93,7 @@ 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 +(dolist (x '(assoc-default butlast last match-string match-string-no-properties member-ignore-case remove remq)) (put x 'side-effect-free t)) diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 489611d4d16..665733181cb 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. diff --git a/lisp/emacs-lock.el b/lisp/emacs-lock.el index 0a6fa9e6255..b6e28fb2530 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: @@ -182,9 +185,6 @@ 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. diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index a737bb6c11c..ff23484dd05 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -852,8 +852,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. @@ -884,10 +882,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))))))) diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index fe57535a14b..3c66abe3e56 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) diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el index 347e66f8ff1..d95a828614e 100644 --- a/lisp/emulation/viper-ex.el +++ b/lisp/emulation/viper-ex.el @@ -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)) diff --git a/lisp/emulation/viper-keym.el b/lisp/emulation/viper-keym.el index e72842232e4..5196ca6ac38 100644 --- a/lisp/emulation/viper-keym.el +++ b/lisp/emulation/viper-keym.el @@ -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) diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el index f0540401803..2e759bc13be 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -39,13 +39,9 @@ (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) @@ -886,6 +882,9 @@ Otherwise return the normal value." (if (featurep 'xemacs) (mark-marker t) (mark-marker))) +(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 () diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el index c8eca30e88b..8604020b987 100644 --- a/lisp/emulation/viper.el +++ b/lisp/emulation/viper.el @@ -937,8 +937,13 @@ Two differences: (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)) + (if (featurep 'xemacs) + (interactive-p) + ;; Respect the spirit of the above comment, though it + ;; seems pointless, since XE doesn't have advice-add or + ;; lexical binding or any other of the newer features + ;; this file uses. + (called-interactively-p 'interactive))) (beep 1) (apply orig-fun args)))) diff --git a/lisp/epa-file.el b/lisp/epa-file.el index 1de2f9ba2d8..866a4ae03a7 100644 --- a/lisp/epa-file.el +++ b/lisp/epa-file.el @@ -147,7 +147,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 +235,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-mail.el b/lisp/epa-mail.el index 077666ac897..7f4c28e9670 100644 --- a/lisp/epa-mail.el +++ b/lisp/epa-mail.el @@ -95,7 +95,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 @@ -111,7 +111,7 @@ If no one is selected, default secret key is used. " (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)) @@ -222,7 +222,7 @@ 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)) diff --git a/lisp/epa.el b/lisp/epa.el index f2989b314a2..c3938e90a71 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,12 +285,6 @@ 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) @@ -565,7 +537,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" @@ -701,7 +673,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 +768,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 +798,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 +840,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 +847,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) @@ -973,7 +941,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 +949,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) @@ -1029,12 +997,6 @@ See the reason described in the `epa-verify-region' documentation." (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))) - ;;;###autoload (defun epa-sign-region (start end signers mode) "Sign the current region between START and END by SIGNERS keys selected. @@ -1057,7 +1019,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 +1044,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 +1059,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 +1107,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 +1132,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 @@ -1340,7 +1300,6 @@ If no one is selected, default public key is exported. "))) ;; (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"))) diff --git a/lisp/epg-config.el b/lisp/epg-config.el index d30ebea2d66..98f458d9962 100644 --- a/lisp/epg-config.el +++ b/lisp/epg-config.el @@ -48,36 +48,53 @@ Setting this variable directly does not take effect; instead use \\[customize] (see the info node `Easy Customization')." :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") diff --git a/lisp/epg.el b/lisp/epg.el index dc0e2df5838..f79f2046ded 100644 --- a/lisp/epg.el +++ b/lisp/epg.el @@ -174,10 +174,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 @@ -211,7 +207,7 @@ output-file result operation - pinentry-mode + (pinentry-mode epg-pinentry-mode) (error-output "") error-buffer) @@ -764,18 +760,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 + (setq user-id (decode-coding-string (epg--decode-percent-escape user-id) 'utf-8)) (error)) @@ -794,17 +785,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 +805,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 +828,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,7 +895,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 + (setq user-id (decode-coding-string (epg--decode-percent-escape user-id) 'utf-8))) (error)) @@ -1196,7 +1176,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 + (setq user-id (decode-coding-string (epg--decode-percent-escape user-id) 'utf-8)) (error)) @@ -1353,7 +1333,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 +1370,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 +1441,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 +1453,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 +1530,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 +1567,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) @@ -1714,7 +1638,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 +1658,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 @@ -1816,7 +1740,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 +1765,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 +1815,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))) diff --git a/lisp/erc/erc-autoaway.el b/lisp/erc/erc-autoaway.el index 4baa1b3cb80..80cb6abe59d 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 ca37ee8f0c9..814ecfae85a 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." diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index cdc8046c086..7599053e9d3 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) @@ -121,9 +121,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 +152,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) @@ -545,5 +549,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 278eaf2506f..85f18fd5e88 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 15de703d803..ce66ff9007f 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) @@ -161,6 +161,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 2ca6a92b66f..fdc209991aa 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -54,9 +54,11 @@ ;;; 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)) @@ -649,9 +651,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 +783,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. @@ -1091,14 +1094,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) @@ -1257,5 +1260,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 f44a6978031..84db0f58e46 100644 --- a/lisp/erc/erc-desktop-notifications.el +++ b/lisp/erc/erc-desktop-notifications.el @@ -98,3 +98,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 e698cea847e..58697506185 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 f980d356e25..5efb8540b61 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-identd.el b/lisp/erc/erc-identd.el index d39a58df204..d710d95cde8 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 05fe1c6738e..f038216cea6 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 a6bf6518ea8..d7ae93316cd 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) @@ -215,6 +215,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 bdc51e77ae7..0bb962dece5 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 babcb5f68ff..584f566f049 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) @@ -215,7 +215,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 +344,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 +457,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 c7ba5adace1..534a5b74205 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 @@ -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 e10a8e193d0..4270ec6d993 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 @@ -148,6 +148,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 0eedd54dde7..885fc49bce5 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 267aecdbb0d..2666598436a 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 e47f471641f..4d78a8c7214 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 64b535d78e1..db0359c9afc 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 4efb9a74b9e..f321ae0228d 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 5a7282dd965..7e315d3b6ed 100644 --- a/lisp/erc/erc-ring.el +++ b/lisp/erc/erc-ring.el @@ -42,7 +42,7 @@ "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." @@ -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 75ae9b51912..ac49a3e12ef 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-2018 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 e68668c5d03..8df8ded44f3 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 109ef281d36..58eefd83cfb 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -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 89f75f13aa2..3a34ea37397 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 17ee2cb17d0..6a648e74358 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) @@ -417,6 +417,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 a45777cb773..7817a0799ef 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -542,7 +542,7 @@ 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: @@ -974,6 +974,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 37744ebfd44..d4359c5c6b3 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 4f1ebe4fad0..0d66fe51069 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 dbf3dac0941..8c4da32e83e 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -67,12 +67,15 @@ ;;; 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) +(require 'subr-x) (defvar erc-official-location "https://www.emacswiki.org/emacs/ERC (mailing list: erc-discuss@gnu.org)" @@ -399,25 +402,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 +431,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 +505,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 @@ -1260,7 +1278,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 +1361,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 +1609,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." @@ -2549,9 +2568,7 @@ consumption for long-lived IRC or Emacs sessions." (maphash (lambda (nick last-PRIVMSG-time) (when - (> (float-time (time-subtract - (current-time) - last-PRIVMSG-time)) + (> (float-time (time-subtract nil last-PRIVMSG-time)) erc-lurker-threshold-time) (remhash nick hash))) hash) @@ -2618,7 +2635,7 @@ server within `erc-lurker-threshold-time'. See also (gethash server erc-lurker-state (make-hash-table))))) (or (null last-PRIVMSG-time) (> (float-time - (time-subtract (current-time) last-PRIVMSG-time)) + (time-subtract nil last-PRIVMSG-time)) erc-lurker-threshold-time)))) (defcustom erc-common-server-suffixes @@ -3677,8 +3694,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) diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index f4b7872f8c9..e79b49095f2 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -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) @@ -437,7 +438,7 @@ 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 diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 37cb6b169a0..ec380e67011 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -207,7 +207,7 @@ Thus, this does not include the current directory.") (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))) @@ -282,7 +282,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,14 +293,14 @@ 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))) diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index 3f863171bd9..62e2f57d0fd 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -218,9 +218,6 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil." (defun eshell-hist-initialize () "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)) @@ -584,21 +581,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 +639,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 (. diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index 2c12cacfff8..b3b16d909ba 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -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)) @@ -545,7 +545,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 da2cfe4dfdd..e61b0eb1c87 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." diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el index 1b0b220d5bc..a5d8e96ba84 100644 --- a/lisp/eshell/em-script.el +++ b/lisp/eshell/em-script.el @@ -61,7 +61,7 @@ This includes when running `eshell-command'." "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) diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el index c45453bf288..9475f4ed949 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) @@ -106,6 +107,7 @@ Uses the system sudo through TRAMP's sudo method." '((?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 c3448de407d..a18fb85507d 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -965,7 +965,7 @@ Show wall-clock time elapsed during execution of COMMAND.") (eshell-stringify-list (eshell-flatten-list (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))) diff --git a/lisp/eshell/em-xtra.el b/lisp/eshell/em-xtra.el index ce73474fb73..cc84d198544 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 diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el index 1bfab23c220..ba5182deb45 100644 --- a/lisp/eshell/esh-ext.el +++ b/lisp/eshell/esh-ext.el @@ -37,8 +37,8 @@ (eval-when-compile (require 'cl-lib) - (require 'esh-io) (require 'esh-cmd)) +(require 'esh-io) (require 'esh-arg) (require 'esh-opt) (require 'esh-proc) diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el index 7d0b362b4c4..d7a449450f9 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -80,6 +80,10 @@ arguments, some do not. The recognized :KEYWORDS are: If present, do not pass MACRO-ARGS through `eshell-flatten-list' 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,8 +99,8 @@ 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)) @@ -111,6 +115,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: @@ -194,11 +200,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 +245,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) diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index 94401c5daa5..a7855d81db5 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -158,7 +158,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 +167,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 +179,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 +199,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." diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 5d38c27eb1d..5ef1ae41297 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -295,7 +295,7 @@ Prepend remote identification of `default-directory', if any." (nconc new-list (list a)))) (cdr new-list))) -(defun eshell-uniqify-list (l) +(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." diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index 1af03d367c3..b5dce80de8c 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -343,6 +343,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) diff --git a/lisp/facemenu.el b/lisp/facemenu.el index be5a18c8cc7..a4f675b8c11 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) diff --git a/lisp/ffap.el b/lisp/ffap.el index 22be2f85369..b51929d2602 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) diff --git a/lisp/filecache.el b/lisp/filecache.el index eaf2cfc92e0..9dd631001da 100644 --- a/lisp/filecache.el +++ b/lisp/filecache.el @@ -1,4 +1,4 @@ -;;; 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-2018 Free Software Foundation, Inc. @@ -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/filenotify.el b/lisp/filenotify.el index 21c9cc23df9..59a8c0e88aa 100644 --- a/lisp/filenotify.el +++ b/lisp/filenotify.el @@ -307,12 +307,12 @@ FILE is the name of the file whose event is being reported." (unless (functionp callback) (signal 'wrong-type-argument `(,callback))) - (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)))) - 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)))) + desc func l-flags) (unless (file-directory-p dir) (signal 'file-notify-error `("Directory does not exist" ,dir))) @@ -363,6 +363,10 @@ FILE is the name of the file whose event is being reported." func (if (eq file-notify--library 'kqueue) file dir) l-flags 'file-notify-callback))) + ;; We do not want to enter quoted file names into the hash. + (setq file (file-name-unquote file) + dir (file-name-unquote dir)) + ;; Modify `file-notify-descriptors'. (let ((watch (file-notify--watch-make dir diff --git a/lisp/files.el b/lisp/files.el index d0b7285fdb0..3921040fa9b 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -474,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 @@ -484,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. @@ -495,6 +496,7 @@ functions are called." :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. @@ -514,11 +516,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 @@ -964,7 +968,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 @@ -1802,7 +1807,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 wildcards))) + (switch-to-buffer newbuf))) (when (eq obuf (current-buffer)) ;; This executes if find-file gets an error ;; and does not really find anything. @@ -2005,15 +2014,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) 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 in raw mode" . ?r))) + (read-char-choice + (concat prompt " (y)es or (n)o or (r)aw ") + '(?y ?Y ?n ?N ?r ?R))))) + (cond ((memq choice '(?y ?Y)) nil) + ((memq choice '(?r ?R)) '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 in raw mode. 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." @@ -2093,7 +2134,10 @@ 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) + (when (eq (abort-if-file-too-large + (nth 7 attributes) "open" filename t) + 'raw) + (setf rawfile t)) (warn-maybe-out-of-memory (nth 7 attributes))) (if buf ;; We are using an existing buffer. @@ -2229,8 +2273,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 () @@ -2299,7 +2342,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))) @@ -3317,7 +3361,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") @@ -3625,7 +3669,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. @@ -4010,13 +4055,15 @@ 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-read-from-dir (dir) "Load all variables files in DIR and register a new class and instance. 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) @@ -4031,12 +4078,19 @@ Return the new class name, which is a symbol named DIR." (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 + (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)) (dir-locals-set-class-variables class-name variables) (dir-locals-set-directory-class dir class-name success) @@ -4527,8 +4581,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))))) @@ -5208,9 +5262,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. @@ -5910,7 +5969,11 @@ an auto-save file." (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" @@ -6442,58 +6505,32 @@ 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") (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))))))))) +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 + (format "%.0f" (/ avail 1024)))))) ;; The following expression replaces `dired-move-to-filename-regexp'. (defvar directory-listing-before-filename-regexp @@ -6943,8 +6980,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 @@ -6984,20 +7022,27 @@ 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 + shell-command temporary-file-directory)) (directory-file-name (expand-file-name (unhandled-file-name-directory default-directory))) @@ -7005,35 +7050,49 @@ 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))) + ;; 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. @@ -7044,22 +7103,21 @@ only these files will be asked to be saved." (save-match-data (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))) + (`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)))))) + (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. @@ -7068,32 +7126,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))) diff --git a/lisp/find-dired.el b/lisp/find-dired.el index 4dda3c425c3..ebd14b07579 100644 --- a/lisp/find-dired.el +++ b/lisp/find-dired.el @@ -295,7 +295,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) diff --git a/lisp/foldout.el b/lisp/foldout.el index ead5368bad2..34e3c6da66b 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/font-lock.el b/lisp/font-lock.el index 29d3bc58646..be9fb4dc93f 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -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. diff --git a/lisp/format-spec.el b/lisp/format-spec.el index 31caf931edb..38ce69b6c4d 100644 --- a/lisp/format-spec.el +++ b/lisp/format-spec.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (defun format-spec (format specification) "Return a string based on FORMAT and SPECIFICATION. FORMAT is a string containing `format'-like specs like \"bash %u %k\", diff --git a/lisp/format.el b/lisp/format.el index 9f109e1aa1e..2f198e3eb71 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) diff --git a/lisp/frame.el b/lisp/frame.el index 29c31f41cb1..c3daff44406 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -129,7 +129,7 @@ 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 handle-focus-in (&optional _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 @@ -138,7 +138,7 @@ This function runs the hook `focus-in-hook'." (interactive "e") (run-hooks 'focus-in-hook)) -(defun handle-focus-out (_event) +(defun handle-focus-out (&optional _event) "Handle a focus-out event. Focus-out events are usually bound to this function. Focus-out events occur when no frame has focus. @@ -614,9 +614,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.") @@ -1147,8 +1144,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 @@ -2113,10 +2108,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 @@ -2322,7 +2313,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'. @@ -2349,12 +2339,11 @@ frame receives focus." 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)) + (not blink-cursor-idle-timer) + (display-graphic-p)) (remove-hook 'post-command-hook 'blink-cursor-check) (blink-cursor--start-idle-timer))) -(define-obsolete-variable-alias 'blink-cursor 'blink-cursor-mode "22.1") - (define-minor-mode blink-cursor-mode "Toggle cursor blinking (Blink Cursor mode). With a prefix argument ARG, enable Blink Cursor mode if ARG is @@ -2384,12 +2373,11 @@ terminals, cursor blinking is controlled by the terminal." (add-hook 'focus-out-hook #'blink-cursor-suspend) (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 @@ -2404,19 +2392,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' @@ -2431,18 +2419,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 diff --git a/lisp/frameset.el b/lisp/frameset.el index 0e3363d7ae3..0d7e8025abd 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -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 diff --git a/lisp/generic-x.el b/lisp/generic-x.el index ea2a100a586..d8a7fe3a735 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -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 @@ -1610,7 +1591,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 +1600,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/canlock.el b/lisp/gnus/canlock.el index 7c657ead78d..0bd47cdde9a 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/gnus-agent.el b/lisp/gnus/gnus-agent.el index c69d64546c5..532fd7e7b8e 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") @@ -332,9 +331,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 +360,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) @@ -1108,7 +1103,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 +1118,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) @@ -1513,7 +1508,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)) @@ -2180,7 +2175,7 @@ article counts for each of the method's subscribed groups." 'gnus-agent-file-loading-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) @@ -2833,7 +2828,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) @@ -3089,7 +3084,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)) @@ -3353,9 +3348,9 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) (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) + (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 +3363,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 @@ -3431,9 +3426,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))))))) @@ -3824,7 +3819,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. @@ -4110,7 +4105,7 @@ agent has fetched." (let ((sum 0.0) file) (while (setq file (pop delta)) - (incf sum (float (or (nth 7 (file-attributes + (cl-incf sum (float (or (nth 7 (file-attributes (nnheader-concat path (if (numberp file) @@ -4122,11 +4117,11 @@ agent has fetched." path nil "^-?[0-9]+$" t)) file) (while (setq file (pop info)) - (incf sum (float (or (nth 8 file) 0)))) + (cl-incf sum (float (or (nth 8 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) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 15e88a34227..055f02fb1ab 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) @@ -199,9 +198,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 +208,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)) @@ -761,9 +760,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 +773,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 +786,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 +801,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 +814,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 +826,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) @@ -1826,7 +1807,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) @@ -1966,7 +1947,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")))) @@ -2236,7 +2217,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 +2227,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))))))) @@ -2948,7 +2931,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) @@ -3031,9 +3015,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)." @@ -3638,8 +3619,7 @@ possible values." (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)) + (let* ((real-time (time-subtract nil time)) (real-sec (and real-time (+ (* (float (car real-time)) 65536) (cadr real-time)))) @@ -4727,6 +4707,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)))))) @@ -5230,7 +5215,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))))) @@ -6698,7 +6683,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 @@ -6764,7 +6749,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) @@ -7062,9 +7048,8 @@ If given a prefix, show the hidden text instead." ;; 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 (with-current-buffer gnus-original-article-buffer + (buffer-substring (point-min) (point-max)))) 'article) ;; Check the backlog. ((and gnus-keep-backlog @@ -8240,7 +8225,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 diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index 7003aef24f7..ad25f805ca1 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-sum) @@ -183,7 +183,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))) @@ -290,7 +290,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) diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el index 8afc31327d7..95cb1ca5ecc 100644 --- a/lisp/gnus/gnus-bcklg.el +++ b/lisp/gnus/gnus-bcklg.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) ;;; diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index c3e77ca59b0..6afc52c0fce 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) @@ -735,7 +735,7 @@ If LOW, update the lower bound instead." ;; `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)) + (cons (car nums) (car (last nums))) gnus-cache-active-hashtb)) ;; Go through all the other files. (dolist (file alphs) @@ -863,11 +863,11 @@ supported." (while (setq file (pop files)) (setq attrs (file-attributes file)) (unless (nth 0 attrs) - (incf size (float (nth 7 attrs))))))) + (cl-incf size (float (nth 7 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 diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index 386593be026..bbf9e527db7 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -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 @@ -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)) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index d5970f31265..16bd80dbfa1 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 @@ -368,6 +367,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 +499,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 0bac2cb1ada..f4c0aa73327 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -406,7 +406,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))) diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index 72b0f5cecff..2405c705651 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) @@ -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 @@ -117,7 +117,7 @@ marked with SPECIAL." (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)))))) diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 7a37a86fb6f..7d4be47e41b 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 diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el index d1335fc8c16..a03c6c140cd 100644 --- a/lisp/gnus/gnus-dup.el +++ b/lisp/gnus/gnus-dup.el @@ -29,8 +29,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) (require 'gnus-art) diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index 40c6d511115..f1fd51d5509 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 fea09ea21a5..6af27afbfaa 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) @@ -46,6 +43,8 @@ (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") @@ -1086,6 +1085,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'. @@ -1152,7 +1153,7 @@ The following commands are available: (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) @@ -1359,6 +1360,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 @@ -1898,7 +1901,7 @@ If FIRST-TOO, the current line is also eligible as a target." (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)) @@ -2548,65 +2551,70 @@ 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. If FAR, it is likely that the group is not on the current line. If TEST-MARKED, the line must be marked." (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) + (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. + (if (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe group gnus-active-hashtb))) + (point) + (goto-char start) + nil)))))) (defun gnus-group-next-group (n &optional silent) "Go to next N'th newsgroup. @@ -2998,7 +3006,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 +3029,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))))) @@ -3553,7 +3561,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))) @@ -3921,7 +3929,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) @@ -4102,9 +4110,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 +4130,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 @@ -4367,6 +4381,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 +4395,18 @@ 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)) + (when (gnus-buffer-exists-p buffer) + (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-name))))) + (error "Gnus exit aborted due to unsaved %s buffer" + (buffer-name))))))) + (defun gnus-group-quit () "Quit reading news without updating .newsrc.eld or .newsrc. The hook `gnus-exit-gnus-hook' is called before actually exiting." @@ -4565,7 +4594,7 @@ or `gnus-group-catchup-group-hook'." "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))) + (delta (time-subtract nil time))) (+ (* (nth 0 delta) 65536.0) (nth 1 delta)))) diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index fc0b36b0db1..f097028cb3e 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)) @@ -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 diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index d878e7695a9..3365c826e11 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -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 @@ -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,7 +238,7 @@ "\\\\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)) @@ -443,7 +443,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 .:. diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index a17741b577c..5d5f9ebb670 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) diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index fd5935b87f8..60732c11d54 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -25,8 +25,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) (require 'gnus-art) (require 'gnus-range) diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el index e0dba06d397..2076d8aebe7 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) diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el index f78efdee65b..1c67f5ffba0 100644 --- a/lisp/gnus/gnus-ml.el +++ b/lisp/gnus/gnus-ml.el @@ -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 eeb65e67e88..599b9c61dcf 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) @@ -183,7 +182,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 +203,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 effbe2cc5f4..660bdf73cdf 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) @@ -393,6 +393,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 +536,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) @@ -1037,7 +1038,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 +1114,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)))) @@ -1482,7 +1483,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) @@ -2000,6 +2001,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 8f3efa41675..b6bb5c9c2b7 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 c8ba7ae5c15..dd3793593e0 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 4c0d5218ab8..229d057946e 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) @@ -372,7 +368,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 +439,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 +500,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 +520,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 +543,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 +570,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 +600,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 +636,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 +688,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 @@ -844,21 +840,17 @@ Addresses without a name will say \"noname\"." nil)) (defun gnus-registry-fetch-sender-fast (article) - (gnus-registry-fetch-header-fast "from" article)) + (when-let* ((data (and (numberp article) + (assoc article (gnus-data-list nil))))) + (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) + (assoc article (gnus-data-list nil)))) + (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) @@ -1089,7 +1081,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 +1091,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) @@ -1235,7 +1227,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 a80bb5b7037..aff841760ae 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. @@ -552,7 +552,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)) @@ -734,7 +734,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 +784,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 a6536797662..6878aa69c66 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." @@ -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)) @@ -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)) @@ -2318,7 +2317,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) @@ -2517,7 +2516,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 +2552,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." @@ -2731,8 +2733,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 +3064,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 +3076,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 082ebf15529..379a7f2b5c3 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) @@ -285,15 +285,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 f9795628cc0..dfca5e9d2cb 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) @@ -142,7 +142,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] @@ -189,7 +189,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 +200,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 +221,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 +229,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 +236,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 +243,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) @@ -452,7 +437,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 +594,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 +628,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 @@ -821,12 +808,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 +820,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)) @@ -982,7 +967,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")) @@ -1127,7 +1112,7 @@ Requesting compaction of %s... (this may take a long time)" (and original (gnus-kill-buffer original)))))) (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 +1132,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 +1142,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 2a7a303408e..623055e1f65 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) @@ -1231,14 +1230,14 @@ for new groups, and subscribe the new groups as zombies." (let ((do-sub (gnus-matches-options-n group))) (cond ((eq do-sub 'subscribe) - (incf groups) + (cl-incf groups) (gnus-sethash group group gnus-killed-hashtb) (gnus-call-subscribe-functions gnus-subscribe-options-newsgroup-method group)) ((eq do-sub 'ignore) nil) (t - (incf groups) + (cl-incf groups) (gnus-sethash group group gnus-killed-hashtb) (if gnus-subscribe-hierarchical-interactive (push group new-newsgroups) @@ -1700,7 +1699,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 +1722,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 +1739,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 +1770,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 +1794,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 @@ -1990,15 +1989,10 @@ backend check whether the group actually exists." ;; 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 4096)))) + (dolist (list (list gnus-killed-list gnus-zombie-list)) + (dolist (group list) + (gnus-sethash group nil hashtb))))) (defun gnus-get-killed-groups () "Go through the active hashtb and mark all unknown groups as killed." @@ -2456,10 +2450,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 @@ -2829,73 +2819,75 @@ 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 (nth 5 (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 + (nth 5 (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 + (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))) (gnus-dribble-delete-file) (gnus-group-set-mode-line))))) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index a39af45e92e..e562b30170a 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(require 'cl-lib) (defvar tool-bar-mode) (defvar gnus-tmp-header) @@ -1266,9 +1266,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 @@ -2366,7 +2370,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])))) @@ -2625,6 +2629,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"] @@ -2940,6 +2945,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'. @@ -3803,7 +3810,7 @@ the thread are to be displayed." 1) (t 0)))) (when (and level (zerop level) gnus-tmp-new-adopts) - (incf number + (cl-incf number (apply '+ (mapcar 'gnus-summary-number-of-articles-in-thread gnus-tmp-new-adopts)))) @@ -3992,7 +3999,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. @@ -4405,7 +4412,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))) @@ -4426,7 +4433,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 () @@ -4719,7 +4726,7 @@ 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))) @@ -5463,7 +5470,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 @@ -5737,7 +5744,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))))) @@ -5914,7 +5921,7 @@ 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 @@ -6076,12 +6083,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 @@ -6111,7 +6118,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) @@ -6303,6 +6310,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) @@ -6651,7 +6659,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") @@ -7056,12 +7064,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." @@ -7274,12 +7290,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 @@ -7343,7 +7360,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 @@ -7796,7 +7813,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) @@ -7805,10 +7823,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) @@ -8555,14 +8574,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 @@ -8755,7 +8782,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))) @@ -8887,7 +8914,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)) @@ -8912,7 +8939,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)) @@ -8964,7 +8991,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)) @@ -8980,7 +9007,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) @@ -11142,7 +11169,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))) @@ -11722,7 +11749,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) @@ -11794,7 +11821,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)) @@ -11962,7 +11989,7 @@ Argument REVERSE means reverse order." (interactive "P") (gnus-summary-sort 'chars reverse)) -(defun gnus-summary-sort-by-mark (&optional reverse) +(defun gnus-summary-sort-by-marks (&optional reverse) "Sort the summary buffer by article marks. Argument REVERSE means reverse order." (interactive "P") @@ -11981,7 +12008,8 @@ 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) @@ -12000,7 +12028,9 @@ Argument REVERSE means reverse order." ;; 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. @@ -12270,21 +12300,27 @@ save those articles instead." (if (> (length articles) 1) (format "these %d articles" (length articles)) "this article"))) + valid-names (to-newsgroup - (cond - ((null split-name) - (gnus-group-completing-read - prom - (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t) - 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) - nil prefix 'gnus-group-history (car split-name))) - (t - (gnus-completing-read - prom (nreverse split-name) nil nil 'gnus-group-history)))) + (progn + (mapatoms (lambda (g) + (when (gnus-valid-move-group-p g) + (push g valid-names))) + gnus-active-hashtb) + (cond + ((null split-name) + (gnus-group-completing-read + prom + valid-names + nil prefix nil default)) + ((= 1 (length split-name)) + (gnus-group-completing-read + prom + valid-names + nil prefix 'gnus-group-history (car split-name))) + (t + (gnus-completing-read + prom (nreverse split-name) nil nil 'gnus-group-history))))) (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) encoded) (when to-newsgroup @@ -12359,7 +12395,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)))))) @@ -12532,7 +12568,7 @@ If REVERSE, save parts that do not match TYPE." ;; article numbers for this article. (mail-header-set-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) @@ -12691,6 +12727,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) @@ -12915,7 +12952,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)))) @@ -13002,12 +13039,12 @@ If ALL is a number, fetch this number of articles." 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 0ff25ecd3b5..111f2ae28a4 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -25,7 +25,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-group) @@ -128,7 +128,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) @@ -220,6 +220,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 +304,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,7 +460,7 @@ 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))) not-in-list) @@ -508,7 +510,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))) @@ -562,7 +564,7 @@ articles in the topic and its subtopics." (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) @@ -728,10 +730,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 +774,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 diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el index 8144e0cadc8..d487262c931 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 1c42d7d0ef8..b30e4d125b2 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -32,8 +32,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'time-date) @@ -142,7 +141,7 @@ This is a compatibility function for different Emacsen." "Extract address components from a From header. Given an RFC-822 address FROM, extract full name and canonical 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 @@ -1117,41 +1116,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." @@ -1440,7 +1407,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 @@ -1648,8 +1615,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 f660b861f7b..a171a385956 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 f0c48db10d6..24235d9c718 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 28fd66ca75e..ff3073a6794 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-util) @@ -312,7 +312,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 +344,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)) @@ -513,7 +513,7 @@ should have point." (memq frame '(t 0 visible))) (car (let ((frames (frames-on-display-list))) - (gnus-remove-if (lambda (win) (not (memq (window-frame win) + (seq-remove (lambda (win) (not (memq (window-frame win) frames))) (get-buffer-window-list buffer nil frame))))) (t diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 4af818d9165..2786323f671 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-2018 Free Software ;; Foundation, Inc. @@ -29,10 +29,11 @@ (run-hooks 'gnus-load-hook) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (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 +336,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 +347,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 +364,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 +381,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 +398,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 +415,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 +432,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 +449,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 +463,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 +480,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 +500,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 +517,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 +546,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 +568,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 +588,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,9 +626,16 @@ 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) ;;; @@ -946,9 +695,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 +752,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 +853,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 +2225,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 +2233,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 +2303,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 +2340,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/") @@ -2755,7 +2505,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 @@ -2902,7 +2651,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) @@ -3179,9 +2927,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 +2982,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 +3003,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 +3095,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 @@ -3463,16 +3213,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 +3323,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)))) @@ -3981,8 +3730,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 @@ -4024,13 +3772,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 +4020,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 +4133,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 d2850f4cee3..51f76a4a2e8 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -26,7 +26,7 @@ (require 'format-spec) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'imap)) (autoload 'auth-source-search "auth-source") (autoload 'pop3-movemail "pop3") @@ -439,7 +439,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 @@ -786,7 +786,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))) @@ -1041,7 +1041,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))) @@ -1116,7 +1116,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 461f61f144d..dde9c28656c 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:") "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)) @@ -1241,13 +1252,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" @@ -1341,7 +1352,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" @@ -1436,8 +1448,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) @@ -1450,8 +1460,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) @@ -1464,8 +1472,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) @@ -1478,8 +1484,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) @@ -1492,8 +1496,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) @@ -1506,8 +1508,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) @@ -1520,8 +1520,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) @@ -1534,8 +1532,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) @@ -1548,8 +1544,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) @@ -1562,53 +1556,50 @@ 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)) + `((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))) ,@(if (and mail-header-separator (not (equal mail-header-separator ""))) `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") @@ -2436,7 +2427,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 @@ -2461,10 +2452,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." @@ -2607,6 +2598,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))) + ;;; @@ -2844,8 +2865,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 '(":-)" ":)" @@ -2952,7 +2972,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 @@ -2960,7 +2980,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) @@ -3094,17 +3116,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 @@ -3123,12 +3143,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 () @@ -3219,13 +3239,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) @@ -3545,7 +3565,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)))))) @@ -3586,7 +3606,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) @@ -3754,13 +3774,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? @@ -4278,7 +4298,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: @@ -4310,7 +4330,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. @@ -4383,7 +4403,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) @@ -4605,9 +4625,9 @@ This function could be useful in `message-setup-hook'." (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)))) + (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) @@ -4672,9 +4692,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)))))) @@ -4761,7 +4783,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) @@ -4792,7 +4814,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) @@ -5315,7 +5337,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? ") @@ -5417,7 +5441,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) @@ -5842,10 +5866,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 @@ -6194,7 +6218,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 @@ -6719,9 +6743,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 @@ -6859,6 +6883,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. @@ -6889,6 +6916,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 @@ -7403,7 +7439,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))))) @@ -7877,6 +7914,8 @@ See `gmm-tool-bar-from-list' for the format of the list." :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'. @@ -7903,6 +7942,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\\):" @@ -8126,11 +8166,12 @@ From headers in the original article." (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))))) + (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)) @@ -8226,16 +8267,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) @@ -8248,6 +8292,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--- @@ -8355,6 +8413,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" @@ -8370,6 +8431,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 faf887cbb9d..e292dac16fe 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 87941b88450..3e6883b2a4b 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-2018 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) @@ -323,10 +320,12 @@ 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) @@ -761,7 +760,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 t) @@ -773,15 +772,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") @@ -961,15 +961,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 +982,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 +1032,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)) @@ -1170,9 +1165,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 +1297,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 +1441,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 +1776,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. @@ -1840,13 +1835,14 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t) (mm-convert-shr-links) (mm-handle-set-undisplayer handle - `(lambda () - (let ((inhibit-read-only t)) - (delete-region ,(point-min-marker) - ,(point-max-marker)))))))) + (let ((min (point-min-marker)) + (max (point-max-marker))) + (lambda () + (let ((inhibit-read-only t)) + (delete-region min max)))))))) (defvar shr-image-map) - +(defvar shr-map) (autoload 'widget-convert-button "wid-edit") (defvar widget-keymap) @@ -1860,12 +1856,15 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t) (widget-convert-button 'url-link start end :help-echo (get-text-property start 'help-echo) - :keymap (setq keymap (copy-keymap shr-image-map)) + :keymap (setq keymap (copy-keymap + (if (mm-images-in-region-p start end) + shr-image-map + shr-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)) + (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 diff --git a/lisp/gnus/mm-encode.el b/lisp/gnus/mm-encode.el index 2eec32b9ac0..361e85fbe1f 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 b7c602030d7..fbae669ce94 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-2018 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 b380fae7666..51dc8b89e3a 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 1715097d4f8..1008c60a173 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 fcd97f2b27c..25b156803a6 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-2018 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) @@ -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,17 +821,18 @@ 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) (buffer-string) - (erase-buffer)) t) + (erase-buffer)) + t) " ") "\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 @@ -898,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 e15eba75924..cf6d6d17ed5 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 c11af7060b7..50a927bce23 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -22,7 +22,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (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 @@ -561,7 +563,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 099e5372b48..9a64853edf6 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 @@ -554,7 +554,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 +647,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))))) @@ -903,7 +904,7 @@ 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)) diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index f91aa140e7b..9df33d09377 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 3c9476333fa..9fd72a93d5b 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -27,7 +27,7 @@ (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)) (autoload 'message-make-message-id "message") @@ -548,6 +548,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)) @@ -795,12 +798,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 +815,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 +835,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)))) diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el index 4198f2c0c54..b2056b2fd0d 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 b220a960983..403b5e1af6a 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 44b010c29b6..1b2b13ebe4d 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 faa797aae45..9f80a755713 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)))) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 2d3d3d16a84..0b300c1a16f 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -83,7 +83,6 @@ (require 'nnoo) (require 'nnheader) (require 'nnmail) -(eval-when-compile (require 'cl)) (require 'gnus-start) (require 'gnus-sum) @@ -233,7 +232,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.") @@ -1532,7 +1531,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 28c903cb913..6dc6c338082 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 53864d1bc1b..149406a9a21 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. @@ -765,7 +765,7 @@ 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)) @@ -788,7 +788,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 +927,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 +1040,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 +1078,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 e984bcb382a..cee7c92b3f1 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 9b6a92f10e7..abd17c55086 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)) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 565c9856051..826fd8d8552 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) diff --git a/lisp/gnus/nngateway.el b/lisp/gnus/nngateway.el index b05c4e88073..8b7898c1893 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 77afb09a2a8..b9ce20413fb 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) @@ -237,7 +237,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 <.*> @@ -612,7 +612,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 +784,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) @@ -973,7 +973,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) @@ -1071,14 +1071,11 @@ 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) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index cab1513a164..dc51b5f0f0c 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) @@ -144,7 +144,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) @@ -212,23 +212,24 @@ textual parts.") (defun nnimap-transform-headers () (goto-char (point-min)) (let (article lines size string labels) - (block nil + (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))) @@ -381,7 +382,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) @@ -522,6 +523,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") @@ -541,6 +543,7 @@ textual parts.") (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") @@ -794,7 +797,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) @@ -1145,7 +1148,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 @@ -1408,7 +1411,7 @@ 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)) @@ -1472,7 +1475,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 +1547,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 @@ -1725,7 +1730,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 @@ -1861,7 +1866,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 +1876,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) "" @@ -2166,7 +2173,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 +2185,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 55e00a0b69f..7e5f56e4dd0 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). @@ -530,8 +530,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 +559,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 @@ -644,7 +642,7 @@ skips all prompting." (add-hook 'gnus-summary-mode-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 +667,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 @@ -716,6 +716,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 +755,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 +805,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 +821,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 +959,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)))) @@ -1177,7 +1180,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). @@ -1267,7 +1270,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). @@ -1433,7 +1436,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). @@ -1502,7 +1505,7 @@ 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 _group) "Run QUERY against notmuch. Returns a vector of (group name, file name) pairs (also vectors, actually)." @@ -1662,54 +1665,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) @@ -1809,8 +1764,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 "")) @@ -1818,31 +1772,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)) @@ -1851,7 +1803,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 @@ -1886,7 +1838,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)) @@ -1907,13 +1859,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 88156d1af82..08db5ab5b69 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) @@ -488,7 +488,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))) @@ -665,7 +666,7 @@ nn*-request-list should have been called before calling this function." (setq group (symbol-name group))) (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 +724,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 +764,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 +773,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 +782,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 +928,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 +981,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 +1249,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"))) @@ -1836,8 +1837,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 +1884,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-subtract nil days) (ignore-errors (time-less-p days (time-since time))))))))) (declare-function gnus-group-mark-article-read "gnus-group" (group article)) @@ -1899,7 +1900,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 +2035,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)))) diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 272240f5a9f..d5cfa27c21a 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -68,8 +68,7 @@ (require 'message) (require 'nnmail) -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defconst nnmaildir-version "Gnus") @@ -165,14 +164,14 @@ 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 +(cl-defstruct nnmaildir--grp (name nil :type string) ;; "group.name" (new nil :type list) ;; new/ modtime (cur nil :type list) ;; cur/ modtime @@ -186,7 +185,7 @@ This variable is set by `nnmaildir-request-article'.") (mmth nil :type vector)) ;; obarray 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:" @@ -814,7 +813,7 @@ This variable is set by `nnmaildir-request-article'.") (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 (nth 5 (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))) @@ -856,7 +855,7 @@ 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)) @@ -915,7 +914,7 @@ This variable is set by `nnmaildir-request-article'.") (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort) dirs (if (zerop (length target-prefix)) dirs - (gnus-remove-if + (seq-remove (lambda (dir) (and (>= (length dir) (length target-prefix)) (string= (substring dir 0 @@ -1732,7 +1731,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) @@ -1779,14 +1778,11 @@ This variable is set by `nnmaildir-request-article'.") 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))) + (nnmaildir--prepare server nil) + (when nnmaildir--cur-server + (setq server nnmaildir--cur-server + nnmaildir--cur-server nil) + (unintern (nnmaildir--srv-address server) nnmaildir--servers)) t) (defun nnmaildir-request-close () diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index 3a0035a3116..24188f5c740 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -134,8 +134,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;For (pop (cdr ogroup)). - (require 'nnoo) (require 'gnus-group) (require 'gnus-sum) diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index 57d8d2125f5..05342dae001 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) diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index b8dd3835520..33be64fb8d2 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) @@ -242,12 +241,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) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index a1b7d417ab4..6307e132187 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -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") diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el index 6a61d3d09f2..1e69af65a3b 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) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 3ab7d0893b9..f80e2c51078 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 @@ -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) @@ -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))) @@ -645,7 +645,7 @@ which RSS 2.0 allows." nnrss-directory)))) (setq xml (nnrss-fetch file t)) (setq url (or (nth 2 (assoc group nnrss-server-data)) - (second (assoc group nnrss-group-alist)))) + (cadr (assoc group nnrss-group-alist)))) (unless url (setq url (cdr @@ -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)) @@ -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 (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 c3fc25047b0..2f16b653924 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)))) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index d0d13849370..be9e4955105 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -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,7 +48,7 @@ "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.") @@ -94,7 +94,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 +103,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 +206,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 @@ -237,11 +237,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 @@ -342,9 +342,7 @@ retried once before actually displaying the error report." `(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))) @@ -565,7 +563,7 @@ retried once before actually displaying the error report." (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) @@ -701,7 +699,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 +711,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 +784,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 +849,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 +863,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)))) @@ -937,7 +935,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 +948,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. @@ -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) @@ -1743,26 +1741,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.") diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index 397d44ee2ac..777c5c1bbe0 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) @@ -774,13 +774,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 cac2dae8ebb..a64f10f98a7 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) @@ -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)) @@ -478,7 +476,7 @@ Valid types include `google', `dejanews', and `gmane'.") (rfc2047-encode-string subject)) (unless (nnweb-get-hashtb (mail-header-xref header)) - (mail-header-set-number header (incf (cdr active))) + (mail-header-set-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 +523,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 9ef0598ee09..9bceb4ead90 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 389ae67d1a4..226a4cecdcb 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 3e722d2d82d..ab2a5b0f813 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.el b/lisp/gnus/spam.el index 1c2b3467237..710e0e83cf9 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)) ;;}}} @@ -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)))) @@ -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 diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 9ffb7ff59cd..ec46a479ed8 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -181,8 +181,8 @@ 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 ((pnt (search-forward (concat "\^_" name "\n")))) + (re-search-backward "\^_S\\(.*\\)") (let ((file (match-string 1))) (if (member file build-files) (throw 'loop file) @@ -642,6 +642,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) @@ -721,6 +723,10 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." ((invalid-function void-function) doc-raw)))) (run-hook-with-args 'help-fns-describe-function-functions function) (insert "\n" (or doc "Not documented."))) + (when (or (function-get function 'pure) + (function-get function 'side-effect-free)) + (insert "\nThis function does not change global state, " + "including the match data.")) ;; Avoid asking the user annoying questions if she decides ;; to save the help buffer, when her locale's codeset ;; isn't UTF-8. @@ -1287,7 +1293,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) @@ -1320,12 +1326,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 a13494aa460..56cb080e200 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 @@ -402,7 +421,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) diff --git a/lisp/help.el b/lisp/help.el index 77e32848318..985d9c567a7 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-2018 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) @@ -308,8 +310,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,9 +413,6 @@ 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 @@ -455,6 +452,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 +464,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,11 +474,11 @@ 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)) + (let ((comment-start ";; ") + (comment-column 24)) + (while (not (eobp)) + (comment-indent) + (forward-line 1))) ;; jidanni wants to see the last keystrokes immediately. (set-marker help-window-point-marker (point))))) @@ -593,19 +592,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 +628,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 +715,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 +732,137 @@ 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) 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 "\ + ;; 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: ")) - ((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))))) + (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) + ((eq base 'help-echo) nil) + (t + (setq last-modifiers modifiers) + (push (cons seq raw-seq) 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 +908,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 +971,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 +1067,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 +1089,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))) diff --git a/lisp/hfy-cmap.el b/lisp/hfy-cmap.el index 6dea345f286..ee6e18edb0a 100644 --- a/lisp/hfy-cmap.el +++ b/lisp/hfy-cmap.el @@ -1,15 +1,15 @@ -;;; 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-2018 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 +32,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 +790,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 +814,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 +830,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/hilit-chg.el b/lisp/hilit-chg.el index b8c1fc5a99b..9d4d2d8b383 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: diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index 6ddbbc99f91..10cfca33700 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -448,6 +448,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 +484,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 @@ -584,22 +584,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 +739,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 +752,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 +775,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 +827,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 +1016,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)) @@ -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 a3143e5e29a..a1adb1df35a 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -1033,8 +1033,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 () @@ -1283,6 +1286,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 diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el index 6f7b492b821..6a70a8341a2 100644 --- a/lisp/ibuf-macs.el +++ b/lisp/ibuf-macs.el @@ -301,12 +301,16 @@ bound to the current value of the filter. (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)) + (if (null (ibuffer-push-filter (cons ',name qualifier))) + (message "%s" + (format ,(concat (format "Filter by %s already applied: " description) + " %s") + qualifier)) + (message "%s" + (format ,(concat (format "Filter by %s added: " description) + " %s") + qualifier)) + (ibuffer-update nil t))) (push (list ',name ,description (lambda (buf qualifier) (condition-case nil diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 0a7bfe00a98..0fd29719344 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -224,14 +224,6 @@ view of the buffers." :group 'ibuffer) (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 @@ -349,15 +341,11 @@ directory, like `default-directory'." :type 'regexp :group 'ibuffer) -(define-obsolete-variable-alias 'ibuffer-hooks 'ibuffer-hook "22.1") - (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") - (defcustom ibuffer-mode-hook nil "Hook run upon entry into `ibuffer-mode'." :type 'hook @@ -522,6 +510,7 @@ directory, like `default-directory'." (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) @@ -951,7 +940,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. @@ -1588,7 +1576,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 @@ -1788,9 +1776,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)) @@ -1799,8 +1784,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")))) @@ -2745,7 +2729,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/ido.el b/lisp/ido.el index da0c9d463d1..705e7dd6301 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -1135,6 +1135,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.") @@ -1790,11 +1793,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 @@ -3480,6 +3480,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)))) @@ -4845,10 +4850,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 fb285e80f6e..b4ad69e4c72 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -115,12 +115,12 @@ 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.") @@ -165,6 +165,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 +184,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 +384,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 +436,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 +528,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'. diff --git a/lisp/image-mode.el b/lisp/image-mode.el index c0186f07a1d..c504afa6970 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -758,7 +758,7 @@ was inserted." (edges (and (null image-transform-resize) (window-inside-pixel-edges (get-buffer-window (current-buffer))))) - (type (if (fboundp 'imagemagick-types) + (type (if (image--imagemagick-wanted-p filename) 'imagemagick (image-type file-or-data nil data-p))) (image (if (not edges) @@ -780,7 +780,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, @@ -803,6 +803,12 @@ 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 (memq (intern (upcase (file-name-extension filename)) obarray) + imagemagick-types-inhibit)))) + (defun image-toggle-hex-display () "Toggle between image and hex display." (interactive) diff --git a/lisp/image.el b/lisp/image.el index db820949eda..8d12b680ea9 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))) @@ -973,17 +975,19 @@ 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) + (unless (or (fboundp 'imagemagick-types) (featurep 'ns)) (error "Cannot rescale images without ImageMagick support")) (let ((image (image--get-image))) (image-flush image) - (plist-put (cdr image) :type 'imagemagick) + (when (fboundp 'imagemagick-types) + (plist-put (cdr image) :type 'imagemagick)) image)) (defun image--change-size (factor) @@ -1003,6 +1007,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 @@ -1025,10 +1031,7 @@ default is 20%." (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/gravatar.el b/lisp/image/gravatar.el index a6e65c39c9d..e7c472db1df 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -77,11 +77,7 @@ (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 () diff --git a/lisp/imenu.el b/lisp/imenu.el index f56e7b50396..b4d7d903595 100644 --- a/lisp/imenu.el +++ b/lisp/imenu.el @@ -102,14 +102,7 @@ This variable is buffer-local." :type 'integer :group 'imenu) -(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 diff --git a/lisp/info-look.el b/lisp/info-look.el index 858e246ad2e..dec16cf44cd 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -619,7 +619,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.el b/lisp/info.el index 8743b449976..bbce55f6216 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -868,10 +868,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 @@ -930,7 +933,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)))) @@ -1868,7 +1872,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. @@ -2013,7 +2017,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) diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index 23db54a4a3b..a023d4fbc85 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -1155,6 +1155,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) diff --git a/lisp/international/latin1-disp.el b/lisp/international/latin1-disp.el index 657f79097cd..df2c1dc9a82 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 333fe2aa917..8e69a1c7ab2 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." @@ -355,8 +352,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)))) @@ -1158,10 +1154,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. @@ -1471,12 +1464,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 +1788,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 +1888,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) @@ -1978,28 +1966,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 +2017,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." @@ -2665,12 +2645,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 diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el index ea687f0ae5e..dc095707a2c 100644 --- a/lisp/international/mule-conf.el +++ b/lisp/international/mule-conf.el @@ -1571,6 +1571,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" + ; 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) + ;; 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 7e225607a5a..87a2e993bb4 100644 --- a/lisp/international/mule-diag.el +++ b/lisp/international/mule-diag.el @@ -1103,8 +1103,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.el b/lisp/international/mule.el index 4d0081f5779..a5e7477e758 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -1514,6 +1514,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)))) diff --git a/lisp/isearch.el b/lisp/isearch.el index 3725779703e..1e785a44c51 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -67,8 +67,28 @@ (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 `move', extend the search string by motion commands +that have the `isearch-move' property on their symbols +equal to `enabled', or the shift-translated command is +not disabled by the value `disabled' of the same property. +If `shift-move', extend the search string by motion commands +while holding down the shift key. +Both `move' and `shift-move' extend the search string by yanking text +that ends at the new position after moving point in the current buffer. +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 "Extend the search string by motion commands" move) + (const :tag "Extend the search string by shifted motion keys" shift-move) + (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. @@ -305,10 +325,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 @@ -316,28 +332,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; @@ -480,7 +484,8 @@ 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) @@ -520,6 +525,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) @@ -555,6 +562,9 @@ 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 @@ -566,9 +576,6 @@ specifies the prefix string displayed in the search message. 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. @@ -589,8 +596,8 @@ 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 - ERROR WRAPPED BARRIER CASE-FOLD-SEARCH]") + [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. (defvar isearch-message "") ; text-char-description version of isearch-string @@ -1042,13 +1049,12 @@ 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) @@ -1119,19 +1125,29 @@ NOPUSH is t and EDIT is t." (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. @@ -1225,13 +1241,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. @@ -1299,6 +1318,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. @@ -1313,6 +1334,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 @@ -1331,6 +1354,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) @@ -1374,6 +1399,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 ))) @@ -1396,7 +1422,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) @@ -1565,7 +1593,6 @@ 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)) @@ -1574,10 +1601,10 @@ Turning on character-folding turns off regexp mode.") (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)) + (propertize (format " [%s]" string) 'face 'minibuffer-prompt))) (sit-for 1)) (isearch-define-mode-toggle lax-whitespace " " nil @@ -1764,8 +1791,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) @@ -1824,7 +1849,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 @@ -1837,20 +1864,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))) @@ -1913,7 +1940,8 @@ 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" ()) @@ -2008,6 +2036,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 () @@ -2081,22 +2110,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." @@ -2378,6 +2411,7 @@ the bottom." (goto-char isearch-point)) (defvar isearch-pre-scroll-point nil) +(defvar isearch-pre-move-point nil) (defun isearch-pre-command-hook () "Decide whether to exit Isearch mode before executing the command. @@ -2385,8 +2419,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 @@ -2414,22 +2449,51 @@ before the command is executed globally with terminated Isearch." ;; Swallow the up-event. (read-event) (setq this-command 'isearch-edit-string)) + ;; Don't terminate the search for motion commands. + ((or (and (eq search-exit-option 'move) + (symbolp this-command) + (or (eq (get this-command 'isearch-move) 'enabled) + (and (not (eq (get this-command 'isearch-move) 'disabled)) + (stringp (nth 1 (interactive-form this-command))) + (string-match-p "^^" (nth 1 (interactive-form this-command)))))) + (and (eq search-exit-option 'shift-move) + 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 + (cond + (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))) + (isearch-update)) + ((memq search-exit-option '(move shift-move)) + (when (and isearch-pre-move-point + (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)))) (defun isearch-quote-char (&optional count) "Quote special characters for incremental search. @@ -2514,7 +2578,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 @@ -2628,12 +2693,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 @@ -2676,6 +2745,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) @@ -2703,11 +2774,12 @@ the word mode." 'face 'minibuffer-prompt))) (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 ""))) + (propertize (concat (if c-q-hack "^Q" "") + (if isearch-error + (concat " [" isearch-error "]") + "") + (or isearch-message-suffix-add "")) + 'face 'minibuffer-prompt)) ;; Searching @@ -2730,11 +2802,8 @@ 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." @@ -2746,25 +2815,18 @@ Can be changed via `isearch-search-fun-function' for special needs." (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) - (cond (isearch-regexp-function - (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))))))))) + (funcall + (if isearch-forward #'re-search-forward #'re-search-backward) + (cond (isearch-regexp-function + (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)))) (defun isearch-search-string (string bound noerror) "Search for the first occurrence of STRING or its translation. @@ -2851,7 +2913,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) @@ -2890,8 +2952,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))) @@ -3122,9 +3182,9 @@ since they have special meaning in a regexp." (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) @@ -3144,10 +3204,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. diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 7abd8aed79a..08a27aef5c6 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -124,13 +124,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 +139,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 @@ -268,7 +261,7 @@ current value of `kmacro-counter', but do not increment it." (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)))) @@ -287,8 +280,8 @@ current value of `kmacro-counter', but do not increment it." (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. @@ -790,19 +783,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] @@ -831,7 +823,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) @@ -843,6 +835,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. @@ -853,14 +852,18 @@ 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)) @@ -1219,7 +1222,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) @@ -1239,17 +1242,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)))) @@ -1272,9 +1275,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/ldefs-boot.el b/lisp/ldefs-boot.el index 738ad9e6ea9..35cff524c9d 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -251,7 +251,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-"))) ;;;*** @@ -570,10 +570,6 @@ 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. @@ -941,7 +937,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"))) ;;;*** @@ -1294,7 +1290,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"))) ;;;*** @@ -1730,7 +1726,7 @@ should be non-nil). \(fn)" 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"))) ;;;*** @@ -1983,7 +1979,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 +2239,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-"))) ;;;*** @@ -2646,8 +2642,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'. @@ -3042,7 +3040,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-file-regexp" "no-byte-compile"))) ;;;*** @@ -3050,7 +3048,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 +3058,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 +3066,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 +3079,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 +3087,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 +3102,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 +3117,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 +3132,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 +3140,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 +3162,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 +3264,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 +3272,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 +3336,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 +3385,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 +3399,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 +3456,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 +3484,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 +3498,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 +3531,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 +3553,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-"))) ;;;*** @@ -3626,7 +3624,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 +3657,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 +3679,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"))) ;;;*** @@ -3701,7 +3699,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"))) ;;;*** @@ -3990,7 +3988,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 +4052,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-"))) ;;;*** @@ -4750,7 +4748,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"))) ;;;*** @@ -4791,14 +4789,14 @@ and runs the normal hook `command-history-hook'. \(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"))) ;;;*** @@ -4899,7 +4897,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-"))) ;;;*** @@ -5028,7 +5026,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"))) ;;;*** @@ -5152,7 +5150,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-" "send-invisible" "shell-strip-ctrl-m"))) ;;;*** @@ -5233,11 +5231,6 @@ 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.") - (defvar compilation-finish-functions nil "\ Functions to call when a compilation process finishes. Each function is called with two arguments: the compilation buffer, @@ -5382,7 +5375,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"))) ;;;*** @@ -5407,7 +5400,7 @@ if ARG is omitted or nil. \(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" "make-c" "next-cdabbrev" "num-cmpl-sources" "reset-cdabbrev" "save" "set-c" "symbol-" "use-completion-"))) ;;;*** @@ -5765,7 +5758,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 @@ -6461,7 +6454,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"))) ;;;*** @@ -7195,14 +7188,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 @@ -7307,7 +7292,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-"))) ;;;*** @@ -7404,7 +7389,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"))) ;;;*** @@ -7921,7 +7906,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-"))) ;;;*** @@ -8100,12 +8085,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-"))) ;;;*** @@ -8247,7 +8236,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-"))) ;;;*** @@ -8334,7 +8323,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. @@ -8456,7 +8445,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. @@ -8713,7 +8702,7 @@ Display statistics for a class tree. \(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"))) ;;;*** @@ -8748,7 +8737,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-"))) ;;;*** @@ -8802,7 +8791,7 @@ 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"))) ;;;*** @@ -8849,7 +8838,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"))) ;;;*** @@ -8965,7 +8954,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,7 +9130,7 @@ Toggle edebugging of all forms. \(fn)" 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-"))) ;;;*** @@ -9711,7 +9700,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-"))) ;;;*** @@ -9719,7 +9708,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"))) ;;;*** @@ -9735,7 +9724,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-"))) ;;;*** @@ -9754,7 +9743,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"))) ;;;*** @@ -10051,7 +10040,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"))) ;;;*** @@ -10080,7 +10069,7 @@ Other values are interpreted as usual. \(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"))) ;;;*** @@ -10612,14 +10601,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"))) @@ -10632,144 +10620,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-"))) @@ -10789,44 +10690,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-"))) @@ -10835,114 +10717,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-"))) @@ -10968,176 +10781,105 @@ Interactively select a server to connect to using `erc-server-alist'. ;;;*** -;;;### (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-"))) @@ -11657,7 +11399,7 @@ for \\[find-tag] (which see). \(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" "next-file-list" "select-tags-table-" "snarf-tag-function" "tag" "verify-tags-table-function" "xref-"))) ;;;*** @@ -11828,7 +11570,7 @@ With ARG, insert that many delimiters. \(fn POS TO FONT-OBJECT STRING)" 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"))) ;;;*** @@ -12386,7 +12128,50 @@ 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. + +\(fn)" 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. + +\(fn)" 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-"))) ;;;*** @@ -12508,7 +12293,7 @@ Evaluate the forms in variable `ffap-bindings'. \(fn)" 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"))) ;;;*** @@ -12549,7 +12334,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 @@ -12698,7 +12483,7 @@ Execute BODY, and unwind connection-local variables. (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-" "hack-connection-local-variables" "modify-" "read-file-local-variable"))) ;;;*** @@ -12775,7 +12560,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"))) ;;;*** @@ -12867,7 +12652,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"))) ;;;*** @@ -13450,7 +13235,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-"))) ;;;*** @@ -13471,7 +13256,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-"))) ;;;*** @@ -13946,7 +13731,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-" "nil"))) ;;;*** @@ -14043,7 +13828,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-"))) ;;;*** @@ -14115,7 +13900,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-"))) ;;;*** @@ -14271,7 +14056,7 @@ Make the current buffer look like a nice article. \(fn)" 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-"))) ;;;*** @@ -14361,7 +14146,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"))) ;;;*** @@ -14375,7 +14160,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-"))) ;;;*** @@ -15121,8 +14906,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 @@ -15212,7 +14995,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:[^\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.") @@ -15349,14 +15132,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"))) ;;;*** @@ -15793,7 +15576,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"))) ;;;*** @@ -15883,7 +15666,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-"))) ;;;*** @@ -16002,7 +15785,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-"))) ;;;*** @@ -16026,7 +15809,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"))) ;;;*** @@ -16122,7 +15905,7 @@ This discards the buffer's undo information. \(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-"))) ;;;*** @@ -16349,7 +16132,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"))) ;;;*** @@ -16547,7 +16330,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-"))) ;;;*** @@ -16581,7 +16364,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-"))) ;;;*** @@ -16633,7 +16416,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-"))) ;;;*** @@ -16759,7 +16542,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-"))) ;;;*** @@ -16803,7 +16586,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"))) ;;;*** @@ -16961,7 +16744,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"))) ;;;*** @@ -17002,7 +16785,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, @@ -17015,7 +16798,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-"))) @@ -17101,7 +16884,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"))) ;;;*** @@ -17541,6 +17324,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) @@ -17590,7 +17375,7 @@ See `inferior-emacs-lisp-mode' for details. \(fn)" 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"))) ;;;*** @@ -18280,7 +18065,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. @@ -18470,7 +18255,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-"))) ;;;*** @@ -18862,7 +18647,7 @@ Key map for ispell menu.") (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: @@ -18871,7 +18656,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{}. @@ -18879,7 +18664,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 @@ -19062,7 +18847,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to \(fn)" 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-"))) ;;;*** @@ -19070,7 +18855,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-"))) ;;;*** @@ -19183,7 +18968,7 @@ by `jka-compr-installed'. \(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-"))) ;;;*** @@ -19465,7 +19250,7 @@ The kind of Korean keyboard for Korean input method. \(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"))) ;;;*** @@ -19772,7 +19557,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-"))) ;;;*** @@ -19995,7 +19780,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-"))) ;;;*** @@ -20014,13 +19799,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. @@ -20121,6 +19900,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" "\ @@ -20200,7 +19985,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) @@ -20309,7 +20094,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"))) ;;;*** @@ -20330,7 +20115,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 @@ -20364,7 +20149,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-"))) ;;;*** @@ -20861,7 +20646,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"))) ;;;*** @@ -20913,7 +20698,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"))) ;;;*** @@ -21045,7 +20830,7 @@ Display version information about MH-E and the MH mail handling system. \(fn)" 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-"))) ;;;*** @@ -21309,7 +21094,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-"))) ;;;*** @@ -21504,7 +21289,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-"))) ;;;*** @@ -21752,7 +21537,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-"))) ;;;*** @@ -21787,7 +21572,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"))) ;;;*** @@ -21814,7 +21599,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"))) ;;;*** @@ -22064,7 +21849,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"))) ;;;*** @@ -22342,7 +22127,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-"))) ;;;*** @@ -22648,21 +22433,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-" "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-"))) ;;;*** @@ -22723,7 +22508,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-"))) ;;;*** @@ -22779,8 +22564,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.") @@ -22900,11 +22683,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. @@ -23021,7 +22803,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-"))) ;;;*** @@ -23101,7 +22883,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-"))) ;;;*** @@ -23172,7 +22954,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-"))) ;;;*** @@ -23411,7 +23193,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-"))) ;;;*** @@ -24610,13 +24392,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) @@ -24624,17 +24410,29 @@ 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. + +\(fn)" nil nil) + (autoload 'package-import-keyring "package" "\ Import keys from FILE. @@ -24723,7 +24521,7 @@ 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"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "package" '("bad-signature" "define-package" "describe-package-1" "package-"))) ;;;*** @@ -24738,7 +24536,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" '("add-new-page" "ctl-x-ctl-p-map" "next-page" "original-page-delimiter" "pages-" "previous-page" "sort-pages-"))) ;;;*** @@ -24838,7 +24636,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-"))) ;;;*** @@ -25043,7 +24841,7 @@ Completion for GNU/Linux `mount'. \(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"))) ;;;*** @@ -25272,7 +25070,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"))) @@ -25377,7 +25175,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-"))) ;;;*** @@ -26187,7 +25985,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-"))) ;;;*** @@ -26320,7 +26118,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-"))) ;;;*** @@ -26628,7 +26426,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)) @@ -26661,7 +26459,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"))) ;;;*** @@ -26937,7 +26735,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"))) ;;;*** @@ -27028,7 +26826,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. @@ -27143,7 +26941,7 @@ if ARG is omitted or nil. \(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-"))) ;;;*** @@ -27164,7 +26962,7 @@ matching parts of the target buffer will be highlighted. \(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-"))) ;;;*** @@ -27339,7 +27137,7 @@ 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-"))) ;;;*** @@ -28079,7 +27877,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-"))) ;;;*** @@ -28204,12 +28002,12 @@ than appending to it. Deletes the message after writing if Ask user a multiple choice question. PROMPT should be a string that will be displayed as the prompt. -CHOICES is a list of (KEY NAME [DESCRIPTION]). KEY is a -character to be entered. NAME is a short name for the entry to -be displayed while prompting (if there's room, it might be -shortened). DESCRIPTION is an optional longer explanation that -will be displayed in a help buffer if the user requests more -help. +CHOICES is an alist where the first element in each entry is a +character to be entered, the second element is a short name for +the entry to be displayed while prompting (if there's room, it +might be shortened), and the third, optional entry is a longer +explanation that will be displayed in a help buffer if the user +requests more help. This function translates user input into responses by consulting the bindings in `query-replace-map'; see the documentation of @@ -28220,9 +28018,9 @@ perform the requested window recentering or scrolling and ask again. When `use-dialog-box' is t (the default), this function can pop -up a dialog window to collect the user input. That functionality -requires `display-popup-menus-p' to return t. Otherwise, a -text dialog will be used. +up a dialog window to collect the user input. That functionality +requires `display-popup-menus-p' to return t. Otherwise, a text +dialog will be used. The return value is the matching entry from the CHOICES list. @@ -28959,14 +28757,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-"))) ;;;*** @@ -29007,7 +28805,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-"))) ;;;*** @@ -29057,7 +28855,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-"))) ;;;*** @@ -29144,7 +28942,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-"))) ;;;*** @@ -29200,7 +28998,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"))) ;;;*** @@ -29216,7 +29014,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-"))) ;;;*** @@ -29245,7 +29043,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-"))) ;;;*** @@ -29301,7 +29099,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-"))) ;;;*** @@ -29309,7 +29107,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-"))) ;;;*** @@ -29341,7 +29139,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-"))) ;;;*** @@ -29397,7 +29195,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-"))) ;;;*** @@ -29405,7 +29203,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-"))) ;;;*** @@ -29501,7 +29299,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-"))) ;;;*** @@ -29525,7 +29323,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-"))) ;;;*** @@ -29533,7 +29331,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-"))) ;;;*** @@ -29541,7 +29339,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-"))) ;;;*** @@ -29693,7 +29491,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-"))) ;;;*** @@ -29738,7 +29536,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-"))) ;;;*** @@ -29746,14 +29544,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: @@ -29781,9 +29579,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) @@ -29816,7 +29614,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.") @@ -29868,7 +29666,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. @@ -29930,8 +29728,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. @@ -29984,13 +29782,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 @@ -30050,13 +29848,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.") - -(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 @@ -30160,7 +29951,7 @@ formula: \(fn)" 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"))) ;;;*** @@ -30437,7 +30228,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-"))) ;;;*** @@ -30759,7 +30550,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-"))) ;;;*** @@ -30879,7 +30670,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-"))) ;;;*** @@ -31901,7 +31692,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-"))) ;;;*** @@ -32085,7 +31876,7 @@ Studlify-case the current buffer. ;;;### (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--" "string-" "thread-" "when-let"))) ;;;*** @@ -32181,7 +31972,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"))) ;;;*** @@ -32861,7 +32652,7 @@ converts a table into plain text without frames. It is a companion to \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "table" '("table-" "*table--"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "table" '("*table--" "table-"))) ;;;*** @@ -32960,7 +32751,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-"))) ;;;*** @@ -33003,7 +32794,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-"))) ;;;*** @@ -33056,7 +32847,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-"))) ;;;*** @@ -33065,10 +32856,8 @@ 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) @@ -33407,7 +33196,7 @@ 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-"))) ;;;*** @@ -33546,6 +33335,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 @@ -33646,7 +33443,7 @@ Return the Lisp list at point, or nil if none is found. \(fn)" 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"))) ;;;*** @@ -33899,7 +33696,7 @@ Return a string giving the duration of the Emacs initialization. \(fn)" 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"))) ;;;*** @@ -33999,7 +33796,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"))) ;;;*** @@ -34200,7 +33997,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-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "titdic-cnv" '("batch-miscdic-convert" "ctlau-" "miscdic-convert" "py-converter" "quail-" "quick-" "tit-" "tsang-" "ziranma-converter"))) ;;;*** @@ -34460,7 +34257,7 @@ 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-"))) ;;;*** @@ -34483,6 +34280,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 @@ -34490,14 +34292,14 @@ 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." (if tramp-mode (let ((default-directory temporary-file-directory)) (load "tramp" 'noerror 'nomessage)) (tramp-unload-file-name-handlers)) (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 '(tramp-file-name-handler tramp-completion-file-name-handler tramp-archive-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))))) (defvar tramp-completion-mode nil "\ If non-nil, external packages signal that they are in file name completion.") @@ -34518,6 +34320,35 @@ 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" "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") "\ +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) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'")) + +(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-autoload-file-name-handler)) (put 'tramp-archive-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 @@ -34555,7 +34386,7 @@ 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-"))) ;;;*** @@ -34582,7 +34413,7 @@ 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 4 -1)) package--builtin-versions) +(push (purecopy '(tramp 2 4 0 -1)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trampver" '("tramp-"))) @@ -34962,7 +34793,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-"))) ;;;*** @@ -35735,6 +35566,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-"))) ;;;*** @@ -35777,7 +35617,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"))) ;;;*** @@ -36387,7 +36227,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-"))) @@ -36629,7 +36469,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-"))) ;;;*** @@ -37491,7 +37331,7 @@ Exit View mode and make the current buffer editable. \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "view" '("view-" "View-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "view" '("View-" "view-"))) ;;;*** @@ -37510,7 +37350,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'. \(fn)" 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-"))) ;;;*** @@ -37541,7 +37381,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-"))) ;;;*** @@ -37549,7 +37389,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-"))) ;;;*** @@ -37686,7 +37526,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-"))) ;;;*** @@ -38197,7 +38037,7 @@ 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.") @@ -38256,10 +38096,11 @@ If no window is at the desired location, an error is signaled. (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 MODIFIER)" t nil) +\(fn &optional MODIFIERS)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "windmove" '("windmove-"))) @@ -38344,7 +38185,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"))) ;;;*** @@ -38416,6 +38257,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-"))) ;;;*** @@ -38512,7 +38359,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-"))) ;;;*** @@ -38650,52 +38497,70 @@ 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" -;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el" -;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el" -;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el" -;;;;;; "language/indian.el" "language/japanese.el" "language/khmer.el" -;;;;;; "language/korean.el" "language/lao.el" "language/misc-lang.el" -;;;;;; "language/romanian.el" "language/sinhala.el" "language/slovak.el" -;;;;;; "language/tai-viet.el" "language/thai.el" "language/tibetan.el" -;;;;;; "language/utf-8-lang.el" "language/vietnamese.el" "ldefs-boot.el" -;;;;;; "leim/ja-dic/ja-dic.el" "leim/leim-list.el" "leim/quail/4Corner.el" -;;;;;; "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el" -;;;;;; "leim/quail/CTLau.el" "leim/quail/ECDICT.el" "leim/quail/ETZY.el" -;;;;;; "leim/quail/PY-b5.el" "leim/quail/PY.el" "leim/quail/Punct-b5.el" -;;;;;; "leim/quail/Punct.el" "leim/quail/QJ-b5.el" "leim/quail/QJ.el" -;;;;;; "leim/quail/SW.el" "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el" -;;;;;; "leim/quail/ZOZY.el" "leim/quail/arabic.el" "leim/quail/croatian.el" -;;;;;; "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el" "leim/quail/czech.el" -;;;;;; "leim/quail/georgian.el" "leim/quail/greek.el" "leim/quail/hanja-jis.el" -;;;;;; "leim/quail/hanja.el" "leim/quail/hanja3.el" "leim/quail/hebrew.el" -;;;;;; "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" "leim/quail/latin-ltx.el" -;;;;;; "leim/quail/latin-post.el" "leim/quail/latin-pre.el" "leim/quail/persian.el" -;;;;;; "leim/quail/programmer-dvorak.el" "leim/quail/py-punct.el" -;;;;;; "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" "leim/quail/quick-cns.el" -;;;;;; "leim/quail/rfc1345.el" "leim/quail/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" +;;;;;; "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-titlecase.el" "international/uni-uppercase.el" +;;;;;; "isearch.el" "jit-lock.el" "jka-cmpr-hook.el" "language/burmese.el" +;;;;;; "language/cham.el" "language/chinese.el" "language/cyrillic.el" +;;;;;; "language/czech.el" "language/english.el" "language/ethiopic.el" +;;;;;; "language/european.el" "language/georgian.el" "language/greek.el" +;;;;;; "language/hebrew.el" "language/indian.el" "language/japanese.el" +;;;;;; "language/khmer.el" "language/korean.el" "language/lao.el" +;;;;;; "language/misc-lang.el" "language/romanian.el" "language/sinhala.el" +;;;;;; "language/slovak.el" "language/tai-viet.el" "language/thai.el" +;;;;;; "language/tibetan.el" "language/utf-8-lang.el" "language/vietnamese.el" +;;;;;; "ldefs-boot.el" "leim/ja-dic/ja-dic.el" "leim/leim-list.el" +;;;;;; "leim/quail/4Corner.el" "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" +;;;;;; "leim/quail/CTLau-b5.el" "leim/quail/CTLau.el" "leim/quail/ECDICT.el" +;;;;;; "leim/quail/ETZY.el" "leim/quail/PY-b5.el" "leim/quail/PY.el" +;;;;;; "leim/quail/Punct-b5.el" "leim/quail/Punct.el" "leim/quail/QJ-b5.el" +;;;;;; "leim/quail/QJ.el" "leim/quail/SW.el" "leim/quail/TONEPY.el" +;;;;;; "leim/quail/ZIRANMA.el" "leim/quail/ZOZY.el" "leim/quail/arabic.el" +;;;;;; "leim/quail/croatian.el" "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el" +;;;;;; "leim/quail/czech.el" "leim/quail/georgian.el" "leim/quail/greek.el" +;;;;;; "leim/quail/hanja-jis.el" "leim/quail/hanja.el" "leim/quail/hanja3.el" +;;;;;; "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" +;;;;;; "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" "leim/quail/latin-pre.el" +;;;;;; "leim/quail/persian.el" "leim/quail/programmer-dvorak.el" +;;;;;; "leim/quail/py-punct.el" "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" +;;;;;; "leim/quail/quick-cns.el" "leim/quail/rfc1345.el" "leim/quail/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" diff --git a/lisp/leim/quail/latin-post.el b/lisp/leim/quail/latin-post.el index de321d64193..791152bd65c 100644 --- a/lisp/leim/quail/latin-post.el +++ b/lisp/leim/quail/latin-post.el @@ -1103,6 +1103,7 @@ szz -> sz ("UE" ?Ü) ("ue" ?ü) ("sz" ?ß) + ("SZ" ?ẞ) ("AEE" ["AE"]) ("aee" ["ae"]) @@ -1111,6 +1112,7 @@ szz -> sz ("UEE" ["UE"]) ("uee" ["ue"]) ("szz" ["sz"]) + ("SZZ" ["SZ"]) ("ge" ["ge"]) ("eue" ["eue"]) ("Eue" ["Eue"]) @@ -2184,6 +2186,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 38011d485ba..ca5af94ad29 100644 --- a/lisp/leim/quail/latin-pre.el +++ b/lisp/leim/quail/latin-pre.el @@ -361,13 +361,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" ?ü) @@ -1175,6 +1176,7 @@ of characters from a single Latin-N charset. ("\"E" ?Ë) ("\"I" ?Ï) ("\"O" ?Ö) + ("\"S" ?ẞ) ("\"U" ?Ü) ("\"W" ?Ẅ) ("\"Y" ?Ÿ) diff --git a/lisp/loadhist.el b/lisp/loadhist.el index e2b2ccd510e..566d51a319c 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' @@ -141,8 +143,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/macros.el b/lisp/macros.el index 29314d53c29..4078b983ec6 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-2018 Free Software ;; Foundation, Inc. @@ -31,23 +31,10 @@ ;;; 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) ;;;###autoload (defun insert-kbd-macro (macroname &optional keys) @@ -66,11 +53,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) @@ -137,6 +120,9 @@ use this command, and then save the file." (prin1 char (current-buffer)) (princ (prin1-char char) (current-buffer)))) (insert ?\])) + ;; FIXME: For kmacros, we shouldn't write the (lambda ...) + ;; gunk but instead we should write something more abstract like + ;; (kmacro-create [<keys>] 0 "%d"). (prin1 definition (current-buffer)))) (insert ")\n") (if keys diff --git a/lisp/mail/binhex.el b/lisp/mail/binhex.el index 04044042e9a..299fc0b2341 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-2018 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) @@ -193,7 +191,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) @@ -241,10 +239,10 @@ 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 (lsh bits -16) nil work-buffer) + (binhex-push-char (logand (lsh 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))))) @@ -263,12 +261,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 (lsh bits -16) 255) nil work-buffer) - (binhex-push-char (logand (lsh bits -8) 255) 1 nil + (binhex-push-char (logand (lsh bits -8) 255) nil work-buffer)) ((= counter 2) - (binhex-push-char (logand (lsh bits -10) 255) 1 nil + (binhex-push-char (logand (lsh bits -10) 255) nil work-buffer)))) (if header-only nil (binhex-verify-crc work-buffer @@ -287,7 +285,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/emacsbug.el b/lisp/mail/emacsbug.el index 503919106f0..d4caeed7888 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -116,6 +116,71 @@ This requires either the macOS \"open\" command, or the freedesktop (concat "mailto:" to))) (error "Subject, To or body not found"))))) +(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)) + ;; TODO include other branches here. + ;; MS Windows: systeminfo ? + ;; Cygwin, *BSD, etc: ? + (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") @@ -232,13 +297,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 +328,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 diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index e0bd4590b13..6093aecd5c3 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -1396,7 +1396,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 @@ -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) diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el index 65f2421cb9a..db2a30ad15e 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-2018 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. diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index 5a04eea25ac..d35b87046fe 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-2018 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: @@ -92,20 +120,25 @@ After that, changing the prefix key requires manipulating keymaps." ;;; 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." + :version "27.1" :type 'string :group 'footnote) -(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." + :version "27.1" :type 'regexp :group 'footnote) @@ -124,13 +157,21 @@ has no effect on buffers already displaying footnotes." :type 'string :group 'footnote) -(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) +(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) + ;;; Private variables (defvar footnote-style-number nil @@ -148,12 +189,14 @@ has no effect on buffers already displaying footnotes." (defvar footnote-mouse-highlight 'highlight "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 +208,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 +227,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 +245,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 +301,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 +329,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 +343,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 +354,70 @@ 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 + (concat "[" (apply #'concat (apply #'append footnote-hebrew-numeric)) "']+")) +;; (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 +428,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,36 +437,36 @@ 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) ;;; Style utilities & functions -(defun Footnote-style-p (style) +(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) + (let ((alist (if (footnote--style-p footnote-style) (assq footnote-style footnote-style-alist) (nth 0 footnote-style-alist)))) (funcall (nth 1 alist) index))) -(defun Footnote-current-regexp () +(defun footnote--current-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) +(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))) + (setq index-regexp (footnote--current-regexp))) (save-excursion ;; Take care of the pointers first (let ((i 0) locn alist) @@ -387,7 +485,7 @@ styles." (propertize (concat footnote-start-tag - (Footnote-index-to-string (1+ i)) + (footnote--index-to-string (1+ i)) footnote-end-tag) 'footnote-number (1+ i) footnote-mouse-highlight t) nil "\\1")) @@ -406,13 +504,13 @@ styles." (propertize (concat footnote-start-tag - (Footnote-index-to-string (1+ i)) + (footnote--index-to-string (1+ i)) footnote-end-tag) 'footnote-number (1+ i)) nil "\\1")) (setq i (1+ i)))))) -(defun Footnote-assoc-index (key alist) +(defun footnote--assoc-index (key alist) "Give index of key in alist." (let ((i 0) (max (length alist)) rc) (while (and (null rc) @@ -422,33 +520,33 @@ styles." (setq i (1+ i))) rc)) -(defun Footnote-cycle-style () +(defun footnote-cycle-style () "Select next defined footnote style." (interactive) - (let ((old (Footnote-assoc-index footnote-style footnote-style-alist)) + (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))))) + (footnote--refresh-footnotes (nth 2 (nth old footnote-style-alist))))) -(defun Footnote-set-style (&optional style) +(defun footnote-set-style (&optional 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))) + obarray #'footnote--style-p 'require-match)))) + (let ((old (footnote--assoc-index footnote-style footnote-style-alist))) (setq footnote-style style) - (Footnote-refresh-footnotes (nth 2 (nth old footnote-style-alist))))) + (footnote--refresh-footnotes (nth 2 (nth old footnote-style-alist))))) ;; Internal functions -(defun Footnote-insert-numbered-footnote (arg &optional mousable) +(defun footnote--insert-numbered-footnote (arg &optional mousable) "Insert numbered footnote at (point)." (let ((string (concat footnote-start-tag - (Footnote-index-to-string arg) + (footnote--index-to-string arg) footnote-end-tag))) (insert-before-markers (if mousable @@ -456,7 +554,7 @@ styles." string 'footnote-number arg footnote-mouse-highlight t) (propertize string 'footnote-number arg))))) -(defun Footnote-renumber (from to pointer-alist text-alist) +(defun footnote--renumber (_from to pointer-alist text-alist) "Renumber a single footnote." (let* ((posn-list (cdr pointer-alist))) (setcar pointer-alist to) @@ -464,49 +562,40 @@ styles." (while posn-list (goto-char (car posn-list)) (when (looking-back (concat (regexp-quote footnote-start-tag) - (Footnote-current-regexp) + (footnote--current-regexp) (regexp-quote footnote-end-tag)) (line-beginning-position)) (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) + (footnote--current-regexp) (regexp-quote footnote-end-tag))) (replace-match (propertize (concat footnote-start-tag - (Footnote-index-to-string to) + (footnote--index-to-string to) footnote-end-tag) 'footnote-number to))))) -;; Not needed? -(defun Footnote-narrow-to-footnotes () +(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)))))) + (interactive) ; testing + (narrow-to-region (footnote--get-area-point-min) + (footnote--get-area-point-max))) -(defun Footnote-goto-char-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) +(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) @@ -514,9 +603,9 @@ styles." (setq footnote-text-marker-alist (cons (cons arg marker) footnote-text-marker-alist)) (setq footnote-text-marker-alist - (Footnote-sort footnote-text-marker-alist))))) + (footnote--sort footnote-text-marker-alist))))) -(defun Footnote-insert-pointer-marker (arg locn) +(defun footnote--insert-pointer-marker (arg locn) "Insert a marker pointing to footnote ARG, at buffer location LOCN." (let ((marker (make-marker)) alist) @@ -527,14 +616,14 @@ styles." (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))))) + (footnote--sort footnote-pointer-marker-alist))))) -(defun Footnote-insert-footnote (arg) +(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) + (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)) @@ -542,8 +631,8 @@ styles." (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) + (footnote--narrow-to-footnotes)) + (footnote-goto-footnote (1- arg)) ; evil, FIXME (less evil now) ;; (message "Inserting footnote %d" arg) (unless (or (eq arg 1) @@ -552,11 +641,11 @@ styles." "\n\n" (concat "\n" (regexp-quote footnote-start-tag) - (Footnote-current-regexp) + (footnote--current-regexp) (regexp-quote footnote-end-tag))) nil t) (unless (beginning-of-line) t)) - (Footnote-goto-char-point-max) + (footnote--goto-char-point-max) (cond ((not (string-equal footnote-section-tag "")) (re-search-backward @@ -570,46 +659,115 @@ styles." (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))) + (footnote--insert-numbered-footnote arg nil) + (footnote--insert-text-marker arg old-point))) -(defun Footnote-sort (list) +(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. +(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) + (when (and footnote-text-marker-alist + (<= (footnote--get-area-point-min) + (point) + (footnote--get-area-point-max))) + (let ((i 1) alist-txt result) (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 () + (null result)) + (when (< (point) (cdr alist-txt)) + (setq result (car (nth (1- i) footnote-text-marker-alist)))) + (setq i (1+ i))) + (when (and (null result) (null alist-txt)) + (setq result (car (nth (1- i) footnote-text-marker-alist)))) + 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-text-marker-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-text-marker-alist) (point-max)) + ((not before-tag) (cdr (car footnote-text-marker-alist))) + ((string-equal footnote-section-tag "") + (cdr (car footnote-text-marker-alist))) + (t + (save-excursion + (goto-char (cdr (car footnote-text-marker-alist))) + (if (re-search-backward (concat "^" footnote-section-tag-regexp) nil t) + (match-beginning 0) + (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. + (cdr (car footnote-text-marker-alist))))))) + +(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))) ;;; User functions -(defun Footnote-make-hole () +(defun footnote--make-hole () (save-excursion (let ((i 0) (notes (length footnote-pointer-marker-alist)) @@ -622,32 +780,32 @@ Return nil if the cursor is not over a footnote." (setq rc (car alist-ptr))) (save-excursion (message "Renumbering from %s to %s" - (Footnote-index-to-string (car alist-ptr)) - (Footnote-index-to-string + (footnote--index-to-string (car alist-ptr)) + (footnote--index-to-string (1+ (car alist-ptr)))) - (Footnote-renumber (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) +(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") +by using `footnote-back-to-message'." + (interactive "*") (let ((num (if footnote-text-marker-alist (if (< (point) (cl-cadar (last footnote-pointer-marker-alist))) - (Footnote-make-hole) + (footnote--make-hole) (1+ (caar (last footnote-text-marker-alist)))) 1))) (message "Adding footnote %d" num) - (Footnote-insert-footnote num) + (footnote--insert-footnote num) (insert-before-markers (make-string footnote-body-tag-spacing ? )) (let ((opoint (point))) (save-excursion @@ -656,18 +814,18 @@ by using `Footnote-back-to-message'." "\n\n" "\n")) (when footnote-narrow-to-footnotes-when-editing - (Footnote-narrow-to-footnotes))) + (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) +(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)))) @@ -681,7 +839,7 @@ delete the footnote with that number." (save-excursion (goto-char (car locn)) (when (looking-back (concat (regexp-quote footnote-start-tag) - (Footnote-current-regexp) + (footnote--current-regexp) (regexp-quote footnote-end-tag)) (line-beginning-position)) (delete-region (match-beginning 0) (match-end 0)))) @@ -692,20 +850,20 @@ delete the footnote with that number." (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)))))) + (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) + (footnote-renumber-footnotes) (when (and (null footnote-text-marker-alist) (null footnote-pointer-marker-alist)) (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,13 +873,13 @@ 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)) @@ -730,16 +888,16 @@ delete the footnote with that number." (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)) + (footnote--renumber (car alist-ptr) (1+ i) alist-ptr alist-txt)) (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))) + (setq arg (footnote--under-cursor))) (let ((footnote (assq arg footnote-text-marker-alist))) (cond (footnote @@ -755,13 +913,13 @@ specified, jump to the text of that footnote." (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)) @@ -769,13 +927,13 @@ being set it is automatically widened." (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 @@ -798,8 +956,14 @@ play around with the following keys: :lighter footnote-mode-line-string :keymap footnote-minor-mode-map ;; (filladapt-mode t) + (unless adaptive-fill-function + ;; nil and `ignore' have the same semantics for adaptive-fill-function, + ;; but only `ignore' behaves correctly with add/remove-function. + (setq adaptive-fill-function #'ignore)) + (remove-function (local 'adaptive-fill-function) + #'footnote--adaptive-fill-function) (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 +971,12 @@ 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) + (add-function :around (local 'adaptive-fill-function) + #'footnote--adaptive-fill-function) + ;; filladapt is an XEmacs package which AFAIK has never been ported + ;; to Emacs. (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 aa2e0cb3e74..37b2d94e5f5 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-2018 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) @@ -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 1b72d39126d..0af3221fc33 100644 --- a/lisp/mail/ietf-drums.el +++ b/lisp/mail/ietf-drums.el @@ -1,4 +1,4 @@ -;;; ietf-drums.el --- Functions for parsing RFC822bis headers +;;; ietf-drums.el --- Functions for parsing RFC822bis headers -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 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. diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el index 3e8a41fb24c..0175c687b26 100644 --- a/lisp/mail/mail-extr.el +++ b/lisp/mail/mail-extr.el @@ -712,7 +712,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 fc9f8ddab1d..463cec0f539 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) diff --git a/lisp/mail/mailabbrev.el b/lisp/mail/mailabbrev.el index 99c0671b9ba..ba1688f411d 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 @@ -414,7 +414,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 +477,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 424ae675b1a..17b4cdfa4bd 100644 --- a/lisp/mail/mailalias.el +++ b/lisp/mail/mailalias.el @@ -50,14 +50,14 @@ 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) (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 +169,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/rfc2047.el b/lisp/mail/rfc2047.el index dbfde57224a..282fd3846ab 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)))))))) diff --git a/lisp/mail/rfc2231.el b/lisp/mail/rfc2231.el index fb03ab4f220..103af55248a 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-2018 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)))) @@ -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 ab0417bb5c1..99c1a1c3628 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 6b0c93d60cb..12a58b293d0 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 @@ -3399,21 +3392,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. @@ -3802,7 +3789,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") @@ -3836,7 +3823,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) "")))))) @@ -4139,6 +4126,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.") @@ -4287,7 +4275,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)))))) diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el index eee8805ab4c..824b1a59fb9 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 692f67b87d2..3dd486a792a 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -1626,7 +1626,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 b6d0b53ce06..aebc50f4fae 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -55,7 +55,7 @@ :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 +72,11 @@ Otherwise, most addresses look like `angles', but they look like (const parens) (const angles) (const default)) - :version "20.3" + :version "27.1" :group 'sendmail) +(make-obsolete-variable + 'mail-from-style + "Only the `angles' value is valid according to RFC2822" "27.1") ;;;###autoload (defcustom mail-specify-envelope-from nil @@ -104,9 +107,9 @@ being sent is used), or nil (in which case the value of ;;;###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." +so you can remove or alter the Bcc field to override the default." :type 'boolean :group 'sendmail) @@ -185,7 +188,7 @@ be a Babyl file." ;;;###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) @@ -243,15 +246,6 @@ 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") - ;;;###autoload (defcustom mail-citation-hook nil "Hook for modifying a citation just inserted in the mail buffer. @@ -479,7 +473,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 +493,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 +505,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,8 +556,8 @@ 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 @@ -616,7 +614,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 +642,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 +652,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 +661,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") @@ -703,8 +701,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. @@ -786,8 +784,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. @@ -911,7 +913,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 @@ -1227,7 +1229,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 @@ -1239,7 +1241,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) @@ -1302,9 +1304,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))) @@ -1378,8 +1380,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." @@ -1391,7 +1393,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) @@ -1470,7 +1472,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))) @@ -1491,7 +1493,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 @@ -1526,7 +1528,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) @@ -1534,20 +1536,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." @@ -1718,8 +1720,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. @@ -1788,9 +1788,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. @@ -1854,13 +1852,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 diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 571089d2144..8bc3cc78d95 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -1,4 +1,4 @@ -;;; 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-2018 Free Software Foundation, Inc. @@ -138,7 +138,7 @@ The commands enables verbose information from the SMTP server." (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. " +`select-message-coding-system' is called." :type 'coding-system :group 'smtpmail) @@ -179,9 +179,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.") @@ -319,11 +321,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 @@ -508,8 +510,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 @@ -530,7 +531,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) @@ -539,51 +543,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 @@ -662,7 +667,6 @@ 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 @@ -679,7 +683,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 @@ -716,9 +722,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))) @@ -941,8 +946,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")) @@ -988,9 +992,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) @@ -1023,14 +1027,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 60669a0212c..ce061e2d8c2 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))))))) @@ -1887,8 +1880,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 b948acfd522..dfe5c9c902b 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 e1ed1c9eb8e..0cdceca6ff5 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-2018 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." @@ -78,7 +75,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) @@ -110,7 +107,7 @@ used is specified by `uudecode-decoder-program'." (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 +125,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. @@ -216,13 +199,13 @@ If FILE-NAME is non-nil, save the result to FILE-NAME." (if file-name (with-temp-file file-name (unless (featurep 'xemacs) (set-buffer-multibyte nil)) - (insert (apply 'concat (nreverse result)))) + (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 4e3eea729a9..25b4ebb9bda 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-2018 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/man.el b/lisp/man.el index c62a61c708d..1a6eda13b7f 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1526,16 +1526,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 () @@ -1816,7 +1816,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/menu-bar.el b/lisp/menu-bar.el index e2ebd981196..25e016247b3 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -1379,11 +1379,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 +1693,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" diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el index ac31127ce64..fb8a16bd81d 100644 --- a/lisp/mh-e/mh-acros.el +++ b/lisp/mh-e/mh-acros.el @@ -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) diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el index a9f809cfa13..1a77daff9b7 100644 --- a/lisp/mh-e/mh-comp.el +++ b/lisp/mh-e/mh-comp.el @@ -305,24 +305,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:") @@ -1054,6 +1056,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 23078127368..ffeb6937f72 100644 --- a/lisp/mh-e/mh-compat.el +++ b/lisp/mh-e/mh-compat.el @@ -65,7 +65,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 +308,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 05ff672da52..4515144d148 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -410,6 +410,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 +432,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 +879,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 +945,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 +978,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-letter.el b/lisp/mh-e/mh-letter.el index 3f88836ddab..71a4623d1f9 100644 --- a/lisp/mh-e/mh-letter.el +++ b/lisp/mh-e/mh-letter.el @@ -60,17 +60,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 +961,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-show.el b/lisp/mh-e/mh-show.el index 90e2411282c..dae8de00bb8 100644 --- a/lisp/mh-e/mh-show.el +++ b/lisp/mh-e/mh-show.el @@ -774,7 +774,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-thread.el b/lisp/mh-e/mh-thread.el index 41a79b6f0b4..ff8e6602e50 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 66d87262bc9..7bda0a68472 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -177,6 +177,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/minibuffer.el b/lisp/minibuffer.el index 7e7856f3a96..a7e6a8761ff 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -729,7 +729,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))) @@ -1320,7 +1321,7 @@ Repeated uses step through the possible completions." (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 () @@ -1824,12 +1825,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' @@ -1837,7 +1833,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. @@ -2726,17 +2722,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) @@ -2962,6 +2950,8 @@ or a symbol, see `completion-pcm--merge-completions'." (`(,(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))) . ,_) + ;; Unused lexical variable warning due to body not using p1, p2. + ;; https://debbugs.gnu.org/16771 (setq p (cdr p))) (`(star ,(pred symbolp) . ,rest) (setq p `(star . ,rest))) (`(,(pred symbolp) star . ,rest) (setq p `(star . ,rest))) @@ -2993,6 +2983,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'." @@ -3024,7 +3025,8 @@ PATTERN is as returned by `completion-pcm--string->pattern'." (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) @@ -3032,8 +3034,16 @@ 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))) + (while md + (put-text-property start (pop md) + 'font-lock-face 'completions-common-part + str) + (setq start (pop md))) + (put-text-property start end 'font-lock-face 'completions-common-part str) (if (> (length str) pos) diff --git a/lisp/mouse.el b/lisp/mouse.el index 9a3e2235ece..95aada9b155 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -41,8 +41,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 +49,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 +81,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 +90,62 @@ 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) (float-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) #'> #'<) + (- (float-time) (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. @@ -921,7 +922,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 +1027,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 +1036,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. @@ -1144,19 +1142,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 @@ -1949,8 +1943,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]? @@ -1960,7 +1953,6 @@ 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 @@ -2358,8 +2350,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. @@ -2368,8 +2359,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. @@ -2379,8 +2369,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. @@ -2389,16 +2378,14 @@ 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") (defun mouse-drag-and-drop-region (event) "Move text in the region to point where mouse is dragged to. diff --git a/lisp/mpc.el b/lisp/mpc.el index 3941492fa28..81bb5ac35a8 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -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 () diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 44c4989ad06..f055df9ee87 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -52,38 +52,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 diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 9b23b8a4d89..cf9667ac628 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-2018 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 @@ -1399,14 +1399,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 +1684,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 +1733,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 +1873,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 +1916,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) @@ -2868,7 +2868,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 +2876,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)) @@ -3373,6 +3368,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 +3406,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 +3447,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 @@ -3829,7 +3835,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 @@ -4385,10 +4391,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) @@ -4469,6 +4478,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 +4488,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 +5212,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 a84a7b1c716..bf179c8782a 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -713,8 +713,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 +1256,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) diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index f63ab9a15a8..2d9660d127f 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/eudc.el b/lisp/net/eudc.el index 8d1071af727..00d8c60311b 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-2018 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 @@ -776,8 +744,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 +804,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 +861,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 +888,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 +908,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 +924,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 +971,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) @@ -1207,25 +1170,29 @@ queries the server for the existing fields and displays a corresponding form." ;;; 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 XEmacs 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 diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 66b1767b563..97fdabd72bd 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -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,17 @@ 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-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)) @@ -250,7 +256,7 @@ word(s) will be searched for via `eww-search-prefix'." (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)))) (setq url (eww--dwim-expand-url url)) (pop-to-buffer-same-window (if (eq major-mode 'eww-mode) @@ -263,8 +269,13 @@ 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) @@ -272,7 +283,7 @@ word(s) will be searched for via `eww-search-prefix'." (insert (format "Loading %s..." url)) (goto-char (point-min))) (url-retrieve url 'eww-render - (list url nil (current-buffer)))) + (list url nil (current-buffer)))) (defun eww--dwim-expand-url (url) (setq url (string-trim url)) @@ -349,9 +360,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 +372,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 @@ -460,7 +475,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 +561,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 +749,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 @@ -1236,14 +1257,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)))) @@ -1489,7 +1504,8 @@ 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 shr-external-browser 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))) @@ -1797,13 +1813,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 85c9308c0d2..09df019e2ec 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -36,6 +36,7 @@ ;;; Code: (require 'cl-lib) +(require 'puny) (defgroup gnutls nil "Emacs interface to the GnuTLS library." @@ -61,9 +62,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. @@ -154,12 +155,12 @@ trust and key files, and priority string." (cons 'gnutls-x509pki (gnutls-boot-parameters :type 'gnutls-x509pki - :hostname host)))))) + :hostname (puny-encode-domain host))))))) (if nowait process (gnutls-negotiate :process process :type 'gnutls-x509pki - :hostname host)))) + :hostname (puny-encode-domain host))))) (define-error 'gnutls-error "GnuTLS error") @@ -282,13 +283,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 ed615d10eb6..cc1cdd15184 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -221,10 +221,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 diff --git a/lisp/net/imap.el b/lisp/net/imap.el index 3d2a4f948bc..2a2ce8b9c97 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-2018 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. @@ -1900,9 +1896,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) @@ -1956,7 +1950,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 +2139,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 +2212,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 +2453,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 +2587,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 +2596,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 +2681,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 +2710,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 +2807,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 +2873,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/mailcap.el b/lisp/net/mailcap.el index f0694b79ea0..a8ade01e818 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/net-utils.el b/lisp/net/net-utils.el index 9edd42b857a..c9e80804bd3 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -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/network-stream.el b/lisp/net/network-stream.el index f55f5486b62..19e0c6421fb 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -295,7 +295,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 diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 71a1e31d73a..32893d2eea5 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-2018 Free Software Foundation, Inc. @@ -603,7 +603,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 +639,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 +650,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 +707,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 +728,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 +874,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 +1254,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 +1289,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 +1304,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 +1339,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 +1398,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 +1479,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 +1514,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 +1751,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 +1766,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,7 +1799,7 @@ 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-less-p nil (time-add (nth 5 (file-attributes image-name)) (seconds-to-time 86400)))) (newsticker--debug-msg "%s: Getting image for %s skipped" @@ -1853,7 +1841,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 +1902,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") @@ -2008,7 +1996,7 @@ older than TIME." (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)) + (when (time-less-p exp-time nil) (newsticker--debug-msg "Item `%s' from %s has expired on %s" (newsticker--title item) @@ -2020,7 +2008,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 @@ -2293,9 +2281,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 +2349,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 +2395,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 +2487,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 1e37276a242..889404ef098 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 7f3d5d75fdb..59a57293ee8 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/pop3.el b/lisp/net/pop3.el index c2385f7f7e5..2a6807e1aca 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-2018 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) @@ -237,8 +237,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 +249,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 +269,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 +279,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 +367,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) @@ -399,7 +397,7 @@ 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)) @@ -424,7 +422,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 +438,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)) @@ -620,10 +618,8 @@ 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 (nth 8 (decode-time now)))) (when (< zone 0) - (setq sign "-") (setq zone (- zone))) (concat (format-time-string "%d" now) @@ -785,7 +781,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 4bf1a372cb4..efa11cf178d 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 abfca383e09..a5ba26bcdc5 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -155,7 +155,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 diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 5acbec7dcb4..abd969216f3 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -182,6 +182,8 @@ underneath each nick." :type '(repeat string) :group 'rcirc) +(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 @@ -401,7 +403,6 @@ will be killed." (defvar rcirc-nick nil) -(defvar rcirc-prompt-start-marker nil) (defvar rcirc-prompt-end-marker nil) (defvar rcirc-nick-table nil) diff --git a/lisp/net/rfc2104.el b/lisp/net/rfc2104.el index d974ab6a772..57bca2e8788 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-2018 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) @@ -101,7 +101,7 @@ 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)) @@ -110,8 +110,8 @@ In XEmacs return just STRING." (setq partial (rfc2104-string-make-unibyte (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))) diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index fbb0a74978a..ca75d953c43 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)) @@ -612,89 +621,114 @@ The object labels of the found items are returned as list." (error 'wrong-type-argument (cadr attributes))) (setq props (append props - (list :dict-entry - (substring (symbol-name (car attributes)) 1) - (cadr attributes))) + `((:dict-entry + ,(substring (symbol-name (car attributes)) 1) + ,(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 - (list :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 ca7d1ce55a4..6303141c898 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-2018 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))) @@ -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 5582e29c526..1103a930242 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" @@ -133,13 +135,21 @@ 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." +(defface shr-strike-through '((t :strike-through t)) + "Face for <s> elements." + :version "24.1" :group 'shr) (defface shr-link - '((t (:inherit link))) - "Font for link elements." + '((t :inherit link)) + "Face for link elements." + :version "24.1" + :group 'shr) + +(defface shr-selected-link + '((t :inherit shr-link :background "red")) + "Face for link elements." + :version "27.1" :group 'shr) (defvar shr-inhibit-images nil @@ -267,7 +277,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 +356,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,8 +498,11 @@ 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) @@ -689,37 +697,47 @@ 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))))) + ;; We don't want to use the faces on the indentation, because + ;; that's ugly. + (setq props (plist-put props 'face nil)) + (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)) @@ -950,7 +968,9 @@ the mouse click event." (browse-url-mail url)) (t (if external - (funcall shr-external-browser url) + (progn + (funcall shr-external-browser url) + (shr--blink-link)) (browse-url url)))))) (defun shr-save-contents (directory) @@ -1178,12 +1198,24 @@ 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)) + '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 +1351,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)) diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index e6a1e8401d2..cd403072389 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-2018 Free Software Foundation, Inc. @@ -75,7 +75,7 @@ (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") @@ -182,7 +182,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 +206,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 +250,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 +373,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/socks.el b/lisp/net/socks.el index 32362e25434..4a3b13282cf 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-2018 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 + (lsh 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 + (lsh 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/tramp-adb.el b/lisp/net/tramp-adb.el index 58f748bd715..df2160770b1 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -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 @@ -111,7 +111,7 @@ It is used for TCP/IP devices." (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) @@ -196,11 +196,13 @@ pass to the OPERATION." (with-temp-buffer ;; `call-process' does not react on timer under MS Windows. ;; That's why we use `start-process'. + ;; We don't know yet whether we need a user or host name for the + ;; connection vector. We assume we don't, it will be OK in most + ;; of the cases. Otherwise, there might be an additional trace + ;; buffer, which doesn't hurt. (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)) + (v (make-tramp-file-name :method tramp-adb-method)) result) (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) (process-put p 'adjust-window-size-function 'ignore) @@ -242,16 +244,8 @@ pass to the OPERATION." ;; 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)) + v (tramp-drop-volume-letter + (tramp-run-real-handler 'expand-file-name (list localname)))))))) (defun tramp-adb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." @@ -281,13 +275,16 @@ pass to the OPERATION." ;; code could be shared? (defun tramp-adb-handle-file-truename (filename) "Like `file-truename' for Tramp files." - (format - "%s%s" + ;; 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 - method user domain host port + v (with-tramp-file-property v localname "file-truename" - (let ((result nil)) ; result steps in reverse order + (let ((result nil) ; result steps in reverse order + (quoted (tramp-compat-file-name-quoted-p localname))) (tramp-message v 4 "Finding true name for `%s'" filename) (let* ((steps (split-string localname "/" 'omit)) (localnamedir (tramp-run-real-handler @@ -313,12 +310,10 @@ pass to the OPERATION." (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 (mapconcat 'identity + (append + '("") (reverse result) (list thisstep)) + "/"))))) (cond ((string= "." thisstep) (tramp-message v 5 "Ignoring step `.'")) ((string= ".." thisstep) @@ -359,11 +354,19 @@ pass to the OPERATION." (not (string= (substring result -1) "/")))) (setq result (concat result "/")))) + ;; Detect cycle. + (when (and (file-symlink-p filename) + (string-equal result localname)) + (tramp-error + v 'file-error + "Apparent cycle of symbolic links for %s" filename)) + ;; If the resulting localname looks remote, we must quote it + ;; for security reasons. + (when (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)))) - - ;; Preserve trailing "/". - (if (string-equal (file-name-nondirectory filename) "") "/" ""))) + result)))))) (defun tramp-adb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -463,13 +466,19 @@ pass to the OPERATION." 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. @@ -546,8 +555,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))) @@ -557,11 +566,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") @@ -572,8 +581,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))) @@ -666,8 +675,8 @@ 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)) @@ -706,15 +715,15 @@ 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) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let ((time (if (or (null time) (equal time '(0 0))) (current-time) time))) @@ -750,8 +759,8 @@ 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 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 @@ -785,8 +794,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) @@ -829,10 +839,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-error v 'file-already-exists newname)) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-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,8 +877,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))) @@ -901,8 +910,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")))) @@ -946,7 +954,7 @@ 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) @@ -988,7 +996,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (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"))) + (tramp-user-error p "Shell command in progress"))) (if current-buffer-p (progn @@ -1105,8 +1113,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (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-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. @@ -1115,7 +1123,7 @@ 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)) @@ -1260,10 +1268,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. @@ -1293,7 +1297,7 @@ connection if a previous connection has died for some reason." (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 'vector vec) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) @@ -1332,7 +1336,7 @@ 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))) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el new file mode 100644 index 00000000000..42c3d40c1bb --- /dev/null +++ b/lisp/net/tramp-archive.el @@ -0,0 +1,645 @@ +;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2018 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" and +;; ".Z". 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)) +(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> +;;;###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" ;; (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") + "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 . ignore) + (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) + ;; `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) + ;; `find-file-noselect' performed by default handler. + ;; `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-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) + (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))) + + ;; The file archive could be a directory, see Bug#30293. + (if (and 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 +(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-autoload-file-name-handler)) + (put 'tramp-archive-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)) + +(eval-after-load 'url-handler + (progn + (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) + (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 url-handler-regexp archive) + (string-match "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))) + +;;;###tramp-autoload +(defun tramp-archive-cleanup-hash () + "Remove local copies of archives, used by GVFS." + (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 'kill-emacs-hook 'tramp-archive-cleanup-hash) +(add-hook 'tramp-archive-unload-hook + (lambda () + (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-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." + (with-parsed-tramp-file-name + (tramp-archive-gvfs-file-name filename) nil + (tramp-check-cached-permissions v ?r))) + +(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 1db93eadf6b..b40a4d7edd6 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -96,10 +96,7 @@ matching entries of `tramp-connection-properties'." (dolist (elt tramp-connection-properties) (when (string-match (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))) @@ -115,8 +112,7 @@ Returns DEFAULT if not set." (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) @@ -167,7 +163,22 @@ 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))) @@ -182,10 +193,10 @@ 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)) @@ -204,7 +215,7 @@ Remove also properties of all files in subdirectories." ;; 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 @@ -223,7 +234,7 @@ This is suppressed for temporary buffers." (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) @@ -292,7 +303,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 @@ -385,6 +413,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))) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 7adac135ae7..b05f475f2fd 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -80,16 +80,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 @@ -113,13 +104,13 @@ When called interactively, a Tramp connection has to be selected." (when keep-password (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) ;; Remove buffers. (dolist @@ -152,6 +143,10 @@ This includes password cache, file cache, connection cache, buffers." ;; Flush file and connection cache. (clrhash tramp-cache-data) + ;; Cleanup local copies of archives. + (when (bound-and-true-p tramp-archive-enabled) + (tramp-archive-cleanup-hash)) + ;; Remove buffers. (dolist (name (tramp-list-tramp-buffers)) (when (bufferp (get-buffer name)) (kill-buffer name)))) @@ -186,7 +181,9 @@ This includes password cache, file cache, connection cache, buffers." "Submit a bug report to the Tramp developers." (interactive) (catch 'dont-send - (let ((reporter-prompt-for-summary-p t)) + (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)" tramp-version) ; package name and version diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 5bf57638ff8..aa0c99bf9cf 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -40,7 +40,6 @@ (require 'timer) (require 'ucs-normalize) -(require 'trampver) (require 'tramp-loaddefs) ;; For not existing functions, obsolete functions, or functions with a @@ -98,13 +97,6 @@ Add the extension of F, if existing." 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)) @@ -190,11 +182,6 @@ This is a string of ten letters or dashes as in ls -l." (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 @@ -243,6 +230,17 @@ If NAME is a remote file name, the local part of NAME is unquoted." `(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 us `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.") + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-loaddefs 'force) + (unload-feature 'tramp-compat 'force))) + (provide 'tramp-compat) ;;; TODO: diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 39962de8342..87c0c796b69 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", "owncloud" and "sftp". + +;; "gdrive" and "owncloud" 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 @@ -71,23 +73,21 @@ ;; :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,6 +97,7 @@ ;; 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) @@ -108,21 +109,41 @@ (eval-when-compile (require 'custom)) +;; 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.") + ;;;###tramp-autoload (defcustom tramp-gvfs-methods - '("afp" "dav" "davs" "gdrive" "obex" "sftp" "synce") + '("afp" "dav" "davs" "gdrive" "owncloud" "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 "owncloud") (const "sftp") - (const "smb") - (const "synce")))) + (const "smb")))) + +(defconst tramp-goa-methods '("gdrive" "owncloud") + "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 @@ -132,8 +153,6 @@ `("\\`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-autoload (defcustom tramp-gvfs-zeroconf-domain "local" @@ -156,16 +175,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 +296,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> -(defvar tramp-bluez-discovery nil - "Indicator for a running bluetooth device discovery. -It keeps the timestamp of last discovery.") +(defconst tramp-goa-interface-chat "org.gnome.OnlineAccounts.Chat" + "The chat 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.Chat'> +;; </interface> + +(defconst tramp-goa-interface-photos "org.gnome.OnlineAccounts.Photos" + "The photos interface of the GNOME Online Accounts.") + +;; <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 +460,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,6 +511,13 @@ Every entry is a list (NAME ADDRESS).") ":[[:blank:]]+\\(.*\\)$") "Regexp to parse GVFS file system attributes with `gvfs-info'.") +(defconst tramp-gvfs-owncloud-default-prefix "/remote.php/webdav" + "Default prefix for owncloud / nextcloud methods.") + +(defconst tramp-gvfs-owncloud-default-prefix-regexp + (concat (regexp-quote tramp-gvfs-owncloud-default-prefix) "$") + "Regexp of default prefix for owncloud / nextcloud methods.") + ;; New handlers should be added here. ;;;###tramp-autoload @@ -492,7 +540,7 @@ Every entry is a list (NAME ADDRESS).") (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) @@ -564,7 +612,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)) @@ -601,12 +649,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) (not (consp (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)) ((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 +675,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)) (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,7 +711,7 @@ 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 @@ -672,6 +744,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) @@ -735,13 +808,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 +848,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 +863,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") @@ -844,8 +917,7 @@ 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." @@ -945,6 +1017,18 @@ If FILE-SYSTEM is non-nil, return file system attributes." (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 + ;; 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 @@ -1040,11 +1124,6 @@ If FILE-SYSTEM is non-nil, return file system attributes." 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))))) - (defun tramp-gvfs-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -1080,9 +1159,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)) @@ -1097,67 +1177,78 @@ If FILE-SYSTEM is non-nil, return file system attributes." (p (apply '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) + (process-put p 'vector v) (process-put p 'events events) (process-put p 'watch-name localname) (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) ;; 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) (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 "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]+") + (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))) + (setq file (url-unhex-string file))) + (when (string-match ddu (or file1 "")) + (setq file1 (replace-match dd nil nil file1))) + (while (string-match "%\\([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)) @@ -1175,7 +1266,7 @@ file-notify events." (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))) @@ -1200,8 +1291,8 @@ file-notify events." "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 @@ -1257,8 +1348,8 @@ file-notify events." (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) + (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)) @@ -1277,7 +1368,7 @@ file-notify events." (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 +1379,10 @@ file-notify events." (with-parsed-tramp-file-name filename nil (when (string-equal "gdrive" method) (setq method "google-drive")) + (when (string-equal "owncloud" 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 +1407,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 +1438,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 +1477,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 +1518,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,31 +1534,33 @@ 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 + tramp-gvfs-owncloud-default-prefix-regexp prefix)) + (setq method "owncloud")) (when (string-equal "google-drive" method) (setq method "gdrive")) + (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))) (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) + (tramp-flush-file-property v "/" "list-mounts") (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-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))))))) @@ -1529,6 +1603,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,39 +1619,55 @@ 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 + tramp-gvfs-owncloud-default-prefix-regexp prefix)) + (setq method "owncloud")) (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)) + (string-match (concat "^/" (regexp-quote (or share ""))) (tramp-file-name-unquote-localname vec))) - ;; Set prefix, mountpoint and location. - (unless (string-equal prefix "/") - (tramp-set-file-property vec "/" "prefix" prefix)) + ;; 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})\"." @@ -1595,7 +1686,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 "^davs\\|^owncloud" method) "true" "false")) (mount-spec `(:array ,@(cond @@ -1603,11 +1694,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 "^dav\\|^owncloud" 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 +1705,14 @@ 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-match "^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 +1722,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 "^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 +1737,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 +1753,34 @@ 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 + (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)) + "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 @@ -1699,18 +1797,16 @@ connection if a previous connection has died for some reason." :name (tramp-buffer-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 "/")) @@ -1744,7 +1840,8 @@ connection if a previous connection has died for some reason." tramp-gvfs-interface-mountoperation "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" @@ -1791,6 +1888,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) @@ -1834,86 +1934,62 @@ is applied, and it returns t if the return code is zero." (erase-buffer) (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-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." + (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")) + ;; 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:///")))))))))) ;; D-Bus zeroconf functions. @@ -1997,41 +2073,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 +2081,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, owncloud) 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-sh.el b/lisp/net/tramp-sh.el index 02fb8648d80..76dae9cea5e 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -27,6 +27,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'tramp) ;; Pacify byte-compiler. @@ -321,7 +322,6 @@ The string is used in `tramp-methods'.") (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 @@ -954,15 +954,16 @@ busybox awk '{}' </dev/null" (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 \")\"" @@ -1096,8 +1097,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 @@ -1118,11 +1119,13 @@ component is used as the target of the symlink." (defun tramp-sh-handle-file-truename (filename) "Like `file-truename' for Tramp files." - (format - "%s%s" + ;; 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 - 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)) @@ -1174,12 +1177,13 @@ component is used as the target of the symlink." (tramp-compat-file-attribute-type (file-attributes (tramp-make-tramp-file-name - method user domain host port + v (mapconcat 'identity (append '("") (reverse result) (list thisstep)) - "/"))))) + "/") + 'nohop)))) (cond ((string= "." thisstep) (tramp-message v 5 "Ignoring step `.'")) ((string= ".." thisstep) @@ -1223,10 +1227,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)))) - - ;; Preserve trailing "/". - (if (string-equal (file-name-nondirectory filename) "") "/" ""))) + result)) + 'nohop)))) ;; Basic functions. @@ -1293,10 +1295,9 @@ component is used as the target of the symlink." ;; 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") + ((tramp-get-ls-command-with + vec "--quoting-style=literal --show-control-chars")) + ((tramp-get-ls-command-with vec "-w")) (t "")) (tramp-shell-quote-argument localname))) ;; Parse `ls -l' output ... @@ -1330,7 +1331,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 "\"") (read (current-buffer)) (buffer-substring (point) (point-at-eol))))) ;; Return data gathered. @@ -1492,8 +1493,8 @@ of." (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 @@ -1504,8 +1505,8 @@ 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) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let ((time (if (or (null time) (equal time '(0 0))) (current-time) time))) @@ -1597,8 +1598,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) @@ -1638,7 +1638,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. @@ -1828,10 +1828,9 @@ be non-negative integers." ;; 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") + ((tramp-get-ls-command-with + vec "--quoting-style=literal --show-control-chars")) + ((tramp-get-ls-command-with vec "-w")) (t "")) (tramp-get-remote-stat vec) tramp-stat-marker tramp-stat-marker @@ -1932,8 +1931,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 @@ -1999,8 +1998,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) @@ -2047,6 +2046,7 @@ file names." (t2 (tramp-tramp-file-p newname)) (length (tramp-compat-file-attribute-size (file-attributes (file-truename filename)))) + ;; `file-extended-attributes' exists since Emacs 24.4. (attributes (and preserve-extended-attributes (apply 'file-extended-attributes (list filename))))) @@ -2125,14 +2125,16 @@ file names." ;; 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. @@ -2354,15 +2356,6 @@ 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) @@ -2507,7 +2500,7 @@ 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 'vector orig-vec) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) @@ -2518,8 +2511,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))) @@ -2550,7 +2543,7 @@ 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)) + (tramp-flush-directory-properties v (file-name-directory localname)) (save-excursion (tramp-barf-unless-okay v (format "%s %s" @@ -2562,8 +2555,8 @@ The method used must be an out-of-band method." "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)) @@ -2575,8 +2568,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") @@ -2589,7 +2582,7 @@ 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) + (tramp-flush-file-properties v localname) (save-excursion (let ((suffixes dired-compress-file-suffixes) suffix) @@ -2638,10 +2631,12 @@ 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 + 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 @@ -2811,22 +2806,20 @@ 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))) + (let ((vec (process-get proc 'vector))) (when vec (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event) - (tramp-flush-connection-property proc) - (tramp-flush-directory-property vec ""))))) + (tramp-flush-connection-properties proc) + (tramp-flush-directory-properties vec ""))))) ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once @@ -2860,13 +2853,7 @@ the result will be a local, non-Tramp, file name." ;; 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-make-tramp-file-name v nil 'nohop) tramp-initial-end-of-output)) ;; We use as environment the difference to toplevel ;; `process-environment'. @@ -2968,8 +2955,8 @@ the result will be a local, non-Tramp, file name." (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)))))) + (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) @@ -3010,8 +2997,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))) @@ -3044,8 +3030,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")))) @@ -3091,7 +3076,7 @@ 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) @@ -3395,8 +3380,8 @@ the result will be a local, non-Tramp, file name." (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. @@ -3569,19 +3554,7 @@ 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 events @@ -3599,6 +3572,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 @@ -3618,7 +3615,7 @@ Fall back to normal file name handler if no Tramp handler exists." "`%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) + (process-put p 'vector v) ;; Needed for process filter. (process-put p 'events events) (process-put p 'watch-name localname) @@ -3629,9 +3626,67 @@ Fall back to normal file name handler if no Tramp handler exists." (tramp-accept-process-output p 1) (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 "Monitoring not supported\\|No locations given" string) + (delete-process proc)) + + (while (string-match + (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)) + ;; 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 + `(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." @@ -3647,8 +3702,6 @@ 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]*" @@ -3694,12 +3747,11 @@ 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 + (concat "^[^[:blank:]]+" + "[[:blank:]]+\\([^[:blank:]]+\\)+" + "\\([[:blank:]]+\\([^\n\r]+\\)\\)?") + line) (tramp-error proc 'file-notify-error "%s" line)) (let ((object @@ -4033,7 +4085,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 @@ -4571,25 +4623,24 @@ Goes through the list `tramp-inline-compress-commands'." "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 previous-host host)) + (tramp-user-error + item "Host name `%s' does not match `%s'" host previous-host)) + (setq previous-host (concat "^" (regexp-quote host) "$"))))) ;; Result. target-alist)) @@ -4723,7 +4774,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)) @@ -4746,13 +4798,12 @@ 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 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) " ")) @@ -4806,16 +4857,16 @@ 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 elt current-host) (setq r-shell t))) + (setq current-host l-host) - ;; 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) + ;; 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)) ;; Add login environment. (when login-env @@ -5079,11 +5130,12 @@ Return ATTR." (when (string-match "^d" (nth 8 attr)) (setcar attr t)) ;; Convert symlink from `tramp-do-file-attributes-with-stat'. + ;; Decode also multibyte string. (when (consp (car attr)) - (if (and (stringp (caar attr)) - (string-match ".+ -> .\\(.+\\)." (caar attr))) - (setcar attr (match-string 1 (caar attr))) - (setcar attr nil))) + (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)) @@ -5240,14 +5292,7 @@ Nonexistent directories are removed from spec." (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) - x)) + (file-directory-p (tramp-make-tramp-file-name vec x 'nohop)) x)) remote-path))))) @@ -5294,36 +5339,18 @@ 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." +(defun tramp-get-ls-command-with (vec option) + "Return OPTION, if the remote `ls' command supports the OPTION option." (save-match-data - (with-tramp-connection-property vec "ls-dired" - (tramp-message vec 5 "Checking, whether `ls --dired' works") + (with-tramp-connection-property vec (concat "ls" option) + (tramp-message vec 5 "Checking, whether `ls %s' works" option) ;; 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") - (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)))))) + (and + (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." @@ -5467,6 +5494,12 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." vec (format "%s --block-size=1 --output=size,used,avail /" result)) 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." (with-tramp-connection-property vec "gvfs-monitor-dir" diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 7e96142a5f9..0334f052a07 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 ... @@ -119,6 +120,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 +131,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" @@ -149,6 +152,7 @@ call, letting the SMB client use the default one." "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" @@ -226,10 +230,10 @@ See `tramp-actions-before-shell' for more info.") (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (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) @@ -365,8 +369,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 @@ -444,13 +448,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 @@ -521,7 +518,7 @@ pass to the OPERATION." (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) + (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 +528,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,8 +546,8 @@ 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 @@ -595,8 +592,8 @@ 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) (unless (tramp-smb-get-share v) (tramp-error v 'file-error "Target `%s' must contain a share name" newname)) @@ -630,8 +627,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\"" @@ -642,7 +639,12 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (goto-char (point-min)) (search-forward-regexp tramp-smb-errors nil t) (tramp-error - v 'file-error "%s `%s'" (match-string 0) directory)))))) + v 'file-error "%s `%s'" (match-string 0) directory))) + + ;; "rmdir" does not report an error. So we check ourselves. + (when (file-exists-p directory) + (tramp-error + v 'file-error "`%s' not removed." directory))))) (defun tramp-smb-handle-delete-file (filename &optional _trash) "Like `delete-file' for Tramp files." @@ -651,8 +653,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\"" @@ -713,8 +715,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; 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." @@ -736,64 +737,58 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (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))) + (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")) ;; 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))))) + (if (not (zerop (length user))) + (setq args (append args (list "-U" user))) + (setq args (append args (list "-N")))) - ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))))) + (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" (mapconcat 'identity (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." @@ -910,13 +905,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 @@ -1163,8 +1151,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (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)) + (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)))))) @@ -1210,8 +1198,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 @@ -1221,7 +1209,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) @@ -1246,8 +1234,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))) @@ -1328,14 +1315,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) @@ -1371,10 +1358,10 @@ 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 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) + (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)) @@ -1404,15 +1391,9 @@ 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))) @@ -1454,7 +1435,7 @@ component is used as the target of the symlink." (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) + (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) @@ -1473,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 @@ -1535,8 +1516,8 @@ component is used as the target of the symlink." (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. @@ -1569,8 +1550,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)) @@ -1639,6 +1620,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 "\\. \\|\\.$\\| $" 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 @@ -1903,8 +1891,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))) @@ -1981,17 +1969,10 @@ If ARGUMENT is non-nil, use it as argument for (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" vec) + (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. @@ -2012,8 +1993,8 @@ If ARGUMENT is non-nil, use it as argument for smbserver-version (tramp-get-connection-property vec "smbserver-version" smbserver-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 "smbserver-version" smbserver-version)))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 59f4ceaa542..1d6e0146c4d 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -56,6 +56,7 @@ ;;; Code: (require 'tramp-compat) +(require 'trampver) ;; Pacify byte-compiler. (require 'cl-lib) @@ -411,13 +412,18 @@ host runs a registered shell, it shall be added to this list, too." :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. @@ -660,7 +666,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" tramp-syntax)) ;; Cleanup existing buffers. (unless (eq (symbol-value symbol) value) (tramp-cleanup-all-buffers)) @@ -882,7 +888,7 @@ Used in `tramp-make-tramp-file-name'.") "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" @@ -956,6 +962,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 "\\`/\\(" @@ -1149,24 +1162,14 @@ 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.") +(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 . tramp-completion-handle-file-name-all-completions) @@ -1249,12 +1252,15 @@ entry does not exist, return nil." ;;;###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)) @@ -1329,7 +1335,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)) @@ -1359,7 +1365,7 @@ default values are used." (make-tramp-file-name :method method :user user :domain domain :host host :port port - :localname (or localname "") :hop hop))))) + :localname localname :hop hop))))) (defun tramp-buffer-name (vec) "A name for the connection buffer VEC." @@ -1370,31 +1376,65 @@ 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." - (when (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)))) + + (when (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 + localname))) (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 @@ -1421,15 +1461,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) @@ -1515,7 +1548,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. + (set-keymap-parent (current-local-map) special-mode-map)) (current-buffer))) (defsubst tramp-debug-message (vec fmt-string &rest arguments) @@ -1560,12 +1595,12 @@ ARGUMENTS to actually emit the message (if applicable)." (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") + "tramp-message" + "tramp-user-error") t) "$") fn))) @@ -1620,17 +1655,18 @@ applicable)." 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)))) - ;; Append connection buffer for error messages. - (when (= level 1) - (let ((tramp-verbose 0)) - (with-current-buffer (tramp-get-connection-buffer vec-or-proc) + (let ((tramp-verbose 0)) + ;; Append connection buffer for error messages. + (when (= level 1) + (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))))))) + 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 @@ -1642,10 +1678,11 @@ applicable)." "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. @@ -1704,6 +1741,31 @@ 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 pilot error." + (unwind-protect + (apply + 'tramp-error vec-or-proc + ;; `user-error' has appeared in Emacs 24.3. + (if (fboundp 'user-error) 'user-error '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 @@ -2023,6 +2085,7 @@ 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 . @@ -2167,7 +2230,7 @@ preventing reentrant calls of Tramp.") "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)) + (if (tramp-tramp-file-p filename) (save-match-data (setq filename (tramp-replace-environment-variables filename)) (with-parsed-tramp-file-name filename nil @@ -2188,6 +2251,8 @@ Falls back to normal file name handler if no Tramp file name handler exists." (let ((default-directory (tramp-compat-temporary-file-directory))) (load (cadr sf) 'noerror 'nomessage))) +;; (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 @@ -2211,6 +2276,8 @@ Falls back to normal file name handler if no Tramp file name handler exists." (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 @@ -2323,15 +2390,19 @@ remote 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. + ;; if `tramp-syntax' has been changed. We cannot call + ;; `tramp-unload-file-name-handlers', this would result in recursive + ;; loading of Tramp. (dolist (fnh '(tramp-file-name-handler tramp-completion-file-name-handler + tramp-archive-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)))) ;; 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)) @@ -2345,6 +2416,12 @@ remote file names." (put 'tramp-completion-file-name-handler 'operations (mapcar 'car tramp-completion-file-name-handler-alist)) + (when (bound-and-true-p tramp-archive-enabled) + (add-to-list 'file-name-handler-alist + (cons tramp-archive-file-name-regexp + 'tramp-archive-file-name-handler)) + (put 'tramp-archive-file-name-handler 'safe-magic t)) + ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. (dolist (fnh '(epa-file-handler jka-compr-handler)) @@ -2398,6 +2475,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." "Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh '(tramp-file-name-handler tramp-completion-file-name-handler + tramp-archive-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)))))) @@ -2459,7 +2537,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. @@ -2897,8 +2974,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))) @@ -2942,13 +3019,19 @@ 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-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 @@ -2989,17 +3072,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." @@ -3058,10 +3135,6 @@ User is always nil." (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 @@ -3082,19 +3155,14 @@ 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." @@ -3133,13 +3201,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." @@ -3153,17 +3221,18 @@ User is always nil." (defun tramp-handle-file-truename (filename) "Like `file-truename' for Tramp files." - (let ((result (expand-file-name filename)) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; - ;; otherwise they might think that Emacs is hung. - ;; Of course, correctness has to come first. - (numchase-limit 20) - symlink-target) - (format - "%s%s" + ;; Preserve trailing "/". + (funcall + (if (string-equal (file-name-nondirectory filename) "") + 'file-name-as-directory 'identity) + (let ((result (expand-file-name filename)) + (numchase 0) + ;; Don't make the following value larger than necessary. + ;; People expect an error message in a timely fashion when + ;; something is wrong; otherwise they might think that Emacs + ;; is hung. Of course, correctness has to come first. + (numchase-limit 20) + symlink-target) (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)) @@ -3172,7 +3241,7 @@ User is always nil." 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 + v2 (funcall (if (tramp-compat-file-name-quoted-p v2-localname) 'tramp-compat-file-name-quote 'identity) @@ -3183,15 +3252,13 @@ User is always nil." (tramp-compat-file-name-quote symlink-target)) (expand-file-name symlink-target (file-name-directory v2-localname))) - v2-localname))))) + v2-localname)) + 'nohop))) (when (>= numchase numchase-limit) (tramp-error v1 'file-error "Maximum number (%d) of symlinks exceeded" numchase-limit))) - (directory-file-name result))) - - ;; Preserve trailing "/". - (if (string-equal (file-name-nondirectory filename) "") "/" "")))) + (directory-file-name result)))))) (defun tramp-handle-find-backup-file-name (filename) "Like `find-backup-file-name' for Tramp files." @@ -3205,8 +3272,7 @@ 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))) @@ -3311,7 +3377,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) @@ -3355,9 +3421,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) @@ -3450,7 +3514,7 @@ support symbolic links." (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"))) + (tramp-user-error p "Shell command in progress"))) (if current-buffer-p (progn @@ -3501,17 +3565,20 @@ 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. (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 (substitute-in-file-name localname)) + (setq filename + (concat (file-remote-p filename) + (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)))) (defun tramp-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -3545,34 +3612,39 @@ 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 (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))))))))) + +;; 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 @@ -3604,17 +3676,16 @@ 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)))) (defun tramp-action-password (proc vec) "Query the user for a password." @@ -3738,12 +3809,10 @@ 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." ;; 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 @@ -3762,7 +3831,9 @@ 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 (funcall tramp-password-save-function)) + ;; Not successful. (tramp-clear-passwd vec) (delete-process proc) (tramp-error-with-buffer @@ -4113,15 +4184,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)) @@ -4163,11 +4226,12 @@ be granted." ;;;###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) + (stringp tramp-local-host-regexp) (stringp host) (string-match tramp-local-host-regexp host) ;; A port is an indication for an ssh tunnel or alike. (null port) @@ -4178,11 +4242,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 @@ -4192,14 +4252,9 @@ 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-error vec 'file-error "Directory %s not accessible" dir)) @@ -4312,15 +4367,10 @@ 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))) (destination (if (eq destination t) (current-buffer) destination)) output error result) (tramp-message - v 6 "`%s %s' %s %s" + vec 6 "`%s %s' %s %s" program (mapconcat 'identity args " ") infile destination) (condition-case err (with-temp-buffer @@ -4338,8 +4388,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 @@ -4349,15 +4399,10 @@ 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))) (buffer (if (eq buffer t) (current-buffer) buffer)) result) (tramp-message - v 6 "`%s %s' %s %s %s %s" + vec 6 "`%s %s' %s %s %s %s" program (mapconcat 'identity args " ") start end delete buffer) (condition-case err (progn @@ -4370,11 +4415,11 @@ are written with verbosity of 6." (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)) ;;;###tramp-autoload @@ -4384,19 +4429,26 @@ 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. @@ -4405,38 +4457,41 @@ 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)))) @@ -4444,11 +4499,7 @@ Invokes `password-read' if available, `read-passwd' else." (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 @@ -4463,8 +4514,7 @@ Invokes `password-read' if available, `read-passwd' else." (auth-source-forget `(:max 1 ,(and user-domain :user) ,user-domain :host ,host-port :port ,method)) - (password-cache-remove - (tramp-make-tramp-file-name method user domain host port "")))) + (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) ;; Snarfed code from time-date.el. @@ -4541,7 +4591,7 @@ Only works for Bourne-like shells." ;; 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) + (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. diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 25498418dd3..46af51ebfdb 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,7 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.3.4-pre +;; Version: 2.4.0-pre ;; This file is part of GNU Emacs. @@ -33,7 +33,7 @@ ;; should be changed only there. ;;;###tramp-autoload -(defconst tramp-version "2.3.4-pre" +(defconst tramp-version "2.4.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -55,10 +55,9 @@ ;; Check for Emacs version. (let ((x (if (>= emacs-major-version 24) "ok" - (format "Tramp 2.3.4-pre is not fit for %s" - (when (string-match "^.*$" (emacs-version)) - (match-string 0 (emacs-version))))))) - (unless (string-match "\\`ok\\'" x) (error "%s" x))) + (format "Tramp 2.4.0-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. (add-to-list diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el index 351fc9fc305..0a3f2777b9a 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 diff --git a/lisp/newcomment.el b/lisp/newcomment.el index 9827a5d1d9c..cd722663dad 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -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. @@ -996,6 +1004,15 @@ This function is the default value of `uncomment-region-function'." (goto-char (point-max)))))) (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 +1209,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 +1278,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/novice.el b/lisp/novice.el index b9cd568ace9..aaad4fabfe2 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-mode.el b/lisp/nxml/nxml-mode.el index 7dc0be8c8ed..e2b51bc01ab 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) @@ -471,11 +472,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 +493,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 @@ -1510,17 +1510,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/rng-maint.el b/lisp/nxml/rng-maint.el index 46ab3a58f50..2b7d9cca082 100644 --- a/lisp/nxml/rng-maint.el +++ b/lisp/nxml/rng-maint.el @@ -226,11 +226,10 @@ (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))) + (float-time (time-subtract nil start))) val)) (defun rng-time-tokenize-buffer () diff --git a/lisp/obsolete/assoc.el b/lisp/obsolete/assoc.el index 899c9d7a563..66cf67713d1 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/fast-lock.el b/lisp/obsolete/fast-lock.el index e15dfd631ce..41e48c3eafb 100644 --- a/lisp/obsolete/fast-lock.el +++ b/lisp/obsolete/fast-lock.el @@ -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." diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el index ec92b96899a..d03621df3c1 100644 --- a/lisp/obsolete/iswitchb.el +++ b/lisp/obsolete/iswitchb.el @@ -353,8 +353,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 +1245,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) diff --git a/lisp/obsolete/lazy-lock.el b/lisp/obsolete/lazy-lock.el index 010b7ae0f31..54dc799c1f2 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/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/obsolete/mouse-sel.el b/lisp/obsolete/mouse-sel.el index 6caaea217df..52e84f2117c 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 diff --git a/lisp/obsolete/options.el b/lisp/obsolete/options.el deleted file mode 100644 index 41637a6ecf3..00000000000 --- a/lisp/obsolete/options.el +++ /dev/null @@ -1,140 +0,0 @@ -;;; options.el --- edit Options command for Emacs - -;; Copyright (C) 1985, 2001-2018 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/pgg-gpg.el b/lisp/obsolete/pgg-gpg.el index 1bc23cad468..3b890727d14 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 e29dfce43f0..34ec96ec12c 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." @@ -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))) diff --git a/lisp/obsolete/pgg-pgp.el b/lisp/obsolete/pgg-pgp.el index 7f9e764959f..ae75377783e 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 c6294f4368f..af8205525f6 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 57e9197a911..fd35f7d333e 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) diff --git a/lisp/obsolete/sregex.el b/lisp/obsolete/sregex.el index 6ff5133ca02..1099b878e68 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/obsolete/vi.el b/lisp/obsolete/vi.el index a7a98d0ca55..7d44f561d46 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 c0779acc5ea..1d1eccbf241 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. diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index 5bbf5e34ee5..cbfaf88fb45 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 diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el index ff32e28d1e8..9be0d5bc1ff 100644 --- a/lisp/org/org-clock.el +++ b/lisp/org/org-clock.el @@ -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? ")) diff --git a/lisp/org/org-ctags.el b/lisp/org/org-ctags.el index 72ea76fe751..48981743755 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-element.el b/lisp/org/org-element.el index d9c6522e2f0..b32f852ded3 100644 --- a/lisp/org/org-element.el +++ b/lisp/org/org-element.el @@ -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))) diff --git a/lisp/org/org-indent.el b/lisp/org/org-indent.el index 84bac2aa799..bf4e998199e 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) diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el index 510ece1cb19..583633605f4 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-pcomplete.el b/lisp/org/org-pcomplete.el index 88a2e10d854..a9b909d3ae7 100644 --- a/lisp/org/org-pcomplete.el +++ b/lisp/org/org-pcomplete.el @@ -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.el b/lisp/org/org.el index 1373861ad1b..e45bc55b244 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -1071,6 +1071,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 +1097,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 +1490,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 +1529,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. @@ -3005,6 +3006,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 +3039,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 +3343,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 +3353,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 +3800,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 +3820,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." @@ -19324,6 +19326,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. @@ -22922,7 +22927,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) diff --git a/lisp/org/ox-odt.el b/lisp/org/ox-odt.el index a1145a9821c..b878171c51b 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/outline.el b/lisp/outline.el index 7cf56abd23a..669935bbc12 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1100,28 +1100,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/pcmpl-cvs.el b/lisp/pcmpl-cvs.el index a3e2b2f5b3c..dedc0072237 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 505d10c1641..16c992662dd 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\\)\\'" diff --git a/lisp/pcmpl-linux.el b/lisp/pcmpl-linux.el index ce42486fda7..18cc647aac5 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 d3250babe6a..74ddb8b9d78 100644 --- a/lisp/pcmpl-rpm.el +++ b/lisp/pcmpl-rpm.el @@ -96,7 +96,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 90dde265999..1b11afd36bb 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 6078dfd7443..6bdea68c0b9 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 () @@ -950,7 +983,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 +1047,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." @@ -1269,7 +1269,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 +1280,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/play/dunnet.el b/lisp/play/dunnet.el index f22cc240c04..2b8bd9d6b8a 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 74ace06c011..740f436711a 100644 --- a/lisp/play/fortune.el +++ b/lisp/play/fortune.el @@ -313,6 +313,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 193b7da3bd7..6edd085b59a 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-2018 Free Software Foundation, Inc. @@ -86,49 +86,157 @@ 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -228,13 +336,13 @@ static unsigned char gamegrid_bits[] = { 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))))) @@ -376,7 +484,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 diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el index de8abd7abe4..5b05ae13e2f 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/printing.el b/lisp/printing.el index 20b0790670d..2fc2323028f 100644 --- a/lisp/printing.el +++ b/lisp/printing.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2000-2001, 2003-2018 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> +;; Maintainer: 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 +12,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. diff --git a/lisp/progmodes/antlr-mode.el b/lisp/progmodes/antlr-mode.el index 1d4fd4f2bce..775fd878725 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/bat-mode.el b/lisp/progmodes/bat-mode.el index 2910a7a1043..51acc6a949f 100644 --- a/lisp/progmodes/bat-mode.el +++ b/lisp/progmodes/bat-mode.el @@ -84,6 +84,8 @@ . '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/cc-align.el b/lisp/progmodes/cc-align.el index 09887b02f3b..1b48a5a66c9 100644 --- a/lisp/progmodes/cc-align.el +++ b/lisp/progmodes/cc-align.el @@ -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: diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 9315ce400be..31cf0b11596 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -1397,6 +1397,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 () @@ -1434,7 +1444,11 @@ No indentation or other \"electric\" behavior is performed." ((and (not least-enclosing) (consp paren-state) (consp (car paren-state)) - (eq start (cdar paren-state))) + (eq start (cdar paren-state)) + (not + (progn + (c-forward-syntactic-ws) + (looking-at c-symbol-start)))) 'at-function-end) (t ;; Find the start of the current declaration. NOTE: If we're in the @@ -1450,6 +1464,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 +1486,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. @@ -1817,251 +1835,298 @@ 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 decl name-start name-end case-fold-search) + + (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 (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)) + + ;; Pick out the defun name, according to the type of defun. + (cond + ;; struct, union, enum, or similar: + ((save-excursion + (and + (looking-at c-defun-type-name-decl-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) + (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 + (and + (consp + (setq decl + (c-forward-decl-or-cast-1 (c-point 'bosws) 'top nil))) + (setq name-start (car decl)) + (progn (if (and (looking-at c-after-suffixed-type-decl-key) + (match-beginning 1)) + (c-forward-keyword-clause 1)) + t) + (or (eq (char-after) ?{) + (and c-recognize-knr-p + (c-in-knr-argdecl))) + (goto-char name-start) + (c-forward-name) + (eq (char-after) ?\()) + (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))))))))) +(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) - (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)) - - ;; 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) - (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)))))))))) + (c-defun-name-1)))) -(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-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 +2134,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))))) @@ -4737,7 +4803,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 613e2b303d9..53d665477c1 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -81,7 +81,7 @@ (progn (require 'font-lock) (let (font-lock-keywords) - (font-lock-compile-keywords '("\\<\\>")) + (font-lock-compile-keywords '("a\\`")) ; doesn't match anything. font-lock-keywords)))) @@ -219,6 +219,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 @@ -254,6 +255,16 @@ to it is returned. This function does not modify the point or the mark." (end-of-line) (point)))) + ((eq position 'eoll) + `(save-excursion + ,@(if point `((goto-char ,point))) + (while (progn + (end-of-line) + (prog1 (eq (logand 1 (skip-chars-backward "\\\\")) 1))) + (beginning-of-line 2)) + (end-of-line) + (point))) + ((eq position 'boi) `(save-excursion ,@(if point `((goto-char ,point))) @@ -453,6 +464,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. @@ -1775,10 +1793,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 - "\\(\\<\\>\\)" - "\\<\\>"))) + "\\(a\\`\\)" + "a\\`"))) (put 'c-make-keywords-re 'lisp-indent-function 1) diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 317968aafd3..3961ea647cf 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -870,7 +870,7 @@ 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. + "a\\`")) ; Doesn't match anything. ;; Return value. (ret 'same) ;; Positions of the last three sexps or bounds we've stopped at. @@ -1124,7 +1124,16 @@ comment at the start of cc-engine.el for more info." (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)) + (not (looking-at + c-opt-block-decls-with-vars-key))))) (save-excursion (c-forward-sexp) (point))) ;; Just gone back over some paren block? @@ -1273,7 +1282,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))) @@ -4727,56 +4736,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 +4752,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 @@ -5177,6 +5138,9 @@ 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)) (cand (or (car (cddr s)) pos))) @@ -5186,9 +5150,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 +5170,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 +5218,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 +5229,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 @@ -7138,7 +7112,7 @@ 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 "\\(a\\`\\)"))) (c-forward-syntactic-ws) (cond ((eq (char-after) ??) @@ -8548,7 +8522,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 "a\\`")) ; Regexp which doesn't match (when (eq (char-after) ?\() (progn (setq paren-depth (1+ paren-depth)) @@ -8605,6 +8579,7 @@ 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) ?\))))) (if (eq (char-after) ?\)) @@ -8634,31 +8609,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) + (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)) @@ -9527,11 +9510,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 @@ -9829,9 +9811,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)))) @@ -9901,11 +9889,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 @@ -9998,28 +9985,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))))) @@ -10034,10 +10018,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) @@ -10058,34 +10039,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) @@ -10165,7 +10144,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 "a\\`") ; Regexp which doesn't match (save-match-data (save-excursion (not @@ -10516,6 +10495,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. @@ -10554,9 +10537,14 @@ 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 (and (eq braceassignp 'dontknow) + (/= (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 @@ -10631,7 +10619,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) @@ -10921,7 +10910,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))))) @@ -11256,9 +11245,7 @@ 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)) @@ -11350,10 +11337,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 @@ -11464,17 +11450,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) ?<)) @@ -12134,21 +12118,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) ?<)) @@ -12172,8 +12173,7 @@ 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) (eq (char-after) ?:)))) (goto-char placeholder) @@ -12428,6 +12428,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 @@ -12607,18 +12612,21 @@ comment at the start of cc-engine.el for more info." (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 diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index fa9b8f354ef..9d2517f2524 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -682,33 +682,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 +722,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 @@ -1234,10 +1203,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)) diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index 271cc2f8464..1b44c75fe6c 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -208,9 +208,9 @@ the evaluated constant value at compile time." ;; 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. @@ -392,27 +392,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 +451,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))) @@ -514,14 +496,17 @@ 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-re-mark-unbalanced-strings c-change-expand-fl-region) (c objc) '(c-depropertize-new-text c-parse-quotes-after-change + c-after-change-re-mark-unbalanced-strings c-extend-font-lock-region-for-macros c-neutralize-syntax-in-CPP c-change-expand-fl-region) c++ '(c-depropertize-new-text c-parse-quotes-after-change + c-after-change-re-mark-unbalanced-strings c-extend-font-lock-region-for-macros c-after-change-re-mark-raw-strings c-neutralize-syntax-in-CPP @@ -529,6 +514,7 @@ parameters \(point-min) and \(point-max).") c-change-expand-fl-region) java '(c-depropertize-new-text c-parse-quotes-after-change + c-after-change-re-mark-unbalanced-strings c-restore-<>-properties c-change-expand-fl-region) awk '(c-depropertize-new-text @@ -611,12 +597,31 @@ 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." + 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 +855,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 "#" @@ -1274,7 +1301,7 @@ operators." (c--set-difference (c-lang-const c-assignment-operators) '("=") :test 'string-equal))) - "\\<\\>")) + "a\\`")) ; Doesn't match anything. (c-lang-defvar c-assignment-op-regexp (c-lang-const c-assignment-op-regexp)) @@ -1497,7 +1524,7 @@ properly." ;; language) t (if (c-lang-const c-block-comment-ender) (regexp-quote (c-lang-const c-block-comment-ender)) - "\\<\\>")) + "a\\`")) ; Doesn't match anything. (c-lang-defvar c-block-comment-ender-regexp (c-lang-const c-block-comment-ender-regexp)) @@ -1516,7 +1543,7 @@ properly." ;; language) t (if (c-lang-const c-block-comment-starter) (regexp-quote (c-lang-const c-block-comment-starter)) - "\\<\\>")) + "a\\`")) ; Doesn't match anything. (c-lang-defvar c-block-comment-start-regexp (c-lang-const c-block-comment-start-regexp)) @@ -1525,7 +1552,7 @@ 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)) - "\\<\\>")) + "a\\`")) ; Doesn't match anything. (c-lang-defvar c-line-comment-start-regexp (c-lang-const c-line-comment-start-regexp)) @@ -1540,7 +1567,7 @@ properly." (c-lang-defconst c-doc-comment-start-regexp "Regexp to match the start of documentation comments." - t "\\<\\>" + t "a\\`" ; Doesn't match anything. ;; From font-lock.el: `doxygen' uses /*! while others use /**. (c c++ objc) "/\\*[*!]" java "/\\*\\*" @@ -2101,6 +2128,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 +2189,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 +2494,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 +2624,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 +3038,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 "a\\`" ; Doesn't match anything. 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)) @@ -3153,7 +3219,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. - "\\<\\>") + "a\\`") ;; Check that there's no "=" afterwards to avoid matching tokens ;; like "*=". (c objc) (concat "\\(" @@ -3191,7 +3257,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. - "\\<\\>" + "a\\`" ;; Check that there's no "=" afterwards to avoid matching tokens ;; like "*=". (c objc) (concat "\\(\\*\\)" @@ -3350,7 +3416,7 @@ list." (c-lang-defconst c-pre-id-bracelist-key "A regexp matching tokens which, preceding an identifier, signify a bracelist. " - t "\\<\\>" + t "a\\`" ; Doesn't match anything. c++ "new\\([^[:alnum:]_$]\\|$\\)\\|&&?\\(\\S.\\|$\\)") (c-lang-defvar c-pre-id-bracelist-key (c-lang-const c-pre-id-bracelist-key)) @@ -3406,7 +3472,7 @@ the invalidity of the putative template construct." ;; before the '{' of the enum list, to avoid searching too far. "[^][{};/#=]*" "{") - "\\<\\>")) + "a\\`")) ; Doesn't match anything. (c-lang-defvar c-enum-clause-introduction-re (c-lang-const c-enum-clause-introduction-re)) @@ -3522,7 +3588,7 @@ i.e. before \":\". Only used if `c-recognize-colon-labels' is set." "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 "a\\`" ; Doesn't match anything. 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 664f01012b8..f09ca04cfff 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -499,9 +499,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 @@ -563,7 +564,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. @@ -996,9 +997,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 +1009,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 +1073,292 @@ 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 " + (eq (logand (skip-chars-backward "\\\\") 1) 1)) + ;; 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-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-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)))) + + (when (eq end-literal-type 'string) + (setq c-new-END (max c-new-END (cdr end-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 + "\"\\|\\s|" (point-max) t t) + (progn + (c-clear-char-property (1- (point)) 'syntax-table) + (not (eq (char-before) ?\"))))) + (eq (char-before) ?\")) + (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 "\\\\*\"") + (eq (logand (skip-chars-backward "\\\\" beg) 1) 1)) + (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)))) + + ((< c-new-END (point-max)) + (goto-char (1+ c-new-END)) ; might be a newline. + ;; In the following regexp, the initial \n caters for a newline getting + ;; joined to a preceding \ by the removal of what comes between. + (re-search-forward "[\n\r]?\\(\\\\\\(.\\|\n\\|\r\\)\\|[^\\\n\r]\\)*" + nil t) + ;; We're at an EOLL or point-max. + (setq c-new-END (min (1+ (point)) (point-max))) + (goto-char c-new-END) + (if (equal (c-get-char-property (1- (point)) 'syntax-table) '(15)) + (if (memq (char-before) '(?\n ?\r)) + ;; Normally terminated invalid string. + (progn + (backward-sexp) + (c-clear-char-property (1- c-new-END) 'syntax-table) + (c-clear-char-property (point) 'syntax-table)) + ;; Opening " at EOB. + (c-clear-char-property (1- (point)) 'syntax-table)) + (if (c-search-backward-char-property 'syntax-table '(15) c-new-BEG) + ;; Opening " on last line of text (without EOL). + (c-clear-char-property (point) 'syntax-table)))) + + (t (goto-char c-new-END) + (if (c-search-backward-char-property 'syntax-table '(15) c-new-BEG) + (c-clear-char-property (point) 'syntax-table)))) + + (unless (and c-multiline-string-start-char + (not (c-characterp c-multiline-string-start-char))) + (when (eq end-literal-type 'string) + (c-clear-char-property (1- (cdr end-limits)) 'syntax-table)) + + (when (eq beg-literal-type 'string) + (setq c-new-BEG (min c-new-BEG (car beg-limits))) + (c-clear-char-property (car beg-limits) 'syntax-table))))) + +(defun c-after-change-re-mark-unbalanced-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-char-property (car beg-literal-limits) 'syntax-table) + (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) + (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))) + s) + (goto-char + (cond ((null beg-literal-type) + c-new-BEG) + ((eq beg-literal-type 'string) + (car beg-limits)) + (t ; comment + (cdr beg-limits)))) + (while + (and + (< (point) c-new-END) + (progn + ;; Skip over any comments before the next string. + (while (progn + (setq s (parse-partial-sexp (point) c-new-END nil + nil s 'syntax-table)) + (and (not (nth 3 s)) + (< (point) c-new-END) + (not (memq (char-before) c-string-delims))))) + ;; We're at the start of a string. + (memq (char-before) c-string-delims))) + (if (c-unescaped-nls-in-string-p (1- (point))) + (looking-at "\\(\\\\\\(.\\|\n|\\\r\\)\\|[^\"]\\)*") + (looking-at (cdr (assq (char-before) c-string-innards-re-alist)))) + (cond + ((memq (char-after (match-end 0)) '(?\n ?\r)) + (c-put-char-property (1- (point)) 'syntax-table '(15)) + (c-put-char-property (match-end 0) 'syntax-table '(15))) + ((or (eq (match-end 0) (point-max)) + (eq (char-after (match-end 0)) ?\\)) ; \ at EOB + (c-put-char-property (1- (point)) 'syntax-table '(15)))) + (goto-char (min (1+ (match-end 0)) (point-max))) + (setq s nil))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parsing of quotes. ;; @@ -1418,7 +1707,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)) @@ -1829,6 +2119,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 @@ -1916,6 +2207,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)) @@ -1994,7 +2286,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-vars.el b/lisp/progmodes/cc-vars.el index ecf034846bd..047511406d9 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -1647,8 +1647,9 @@ 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 "a\\`") +(defvar c-noise-macro-name-re "a\\`") (defcustom c-noise-macro-names nil "A list of names of macros which expand to nothing, or compiler extensions @@ -1677,7 +1678,7 @@ These are recognized by CC Mode only in declarations." ;; 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) "a\\`") ; Never matches. ((consp c-noise-macro-with-parens-names) (concat (regexp-opt c-noise-macro-with-parens-names t) "\\([^[:alnum:]_$]\\|$\\)")) @@ -1686,7 +1687,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) "a\\`") ; Never matches anything. ((consp c-noise-macro-names) (concat (regexp-opt c-noise-macro-names t) "\\([^[:alnum:]_$]\\|$\\)")) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 422974379ba..15503ee0b25 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -100,16 +100,6 @@ 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") - -;;;###autoload (defvar compilation-finish-functions nil "Functions to call when a compilation process finishes. Each function is called with two arguments: the compilation buffer, @@ -2101,7 +2091,6 @@ by replacing the first word, e.g., `compilation-scroll-output' from 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 @@ -2245,9 +2234,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. diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 6dbdba75de6..18a72324c65 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-2018 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)) @@ -132,7 +118,7 @@ `(progn (beginning-of-line 2) (list ,file ,line))) - (defmacro cperl-etags-snarf-tag (file line) + (defmacro cperl-etags-snarf-tag (_file _line) `(etags-snarf-tag))) (if (featurep 'xemacs) (defmacro cperl-etags-goto-tag-location (elt) @@ -147,12 +133,6 @@ (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))))) - (defun cperl-choose-color (&rest list) (let (answer) (while list @@ -228,10 +208,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 +266,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 @@ -405,13 +390,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,7 +436,7 @@ Font for POD headers." :type 'face :group 'cperl-faces) -;;; Some double-evaluation happened with font-locks... Needed with 21.2... +;; Some double-evaluation happened with font-locks... Needed with 21.2... (defvar cperl-singly-quote-face (featurep 'xemacs)) (defcustom cperl-invalid-face 'underline @@ -612,8 +590,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) @@ -1010,33 +987,15 @@ 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))) + (push (character-to-event c) unread-command-events))) (defvar cperl-do-not-fontify + ;; FIXME: This is not doing what it claims! (if (string< emacs-version "19.30") 'fontified 'lazy-lock) @@ -1056,8 +1015,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 +1042,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 +1178,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 +1206,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 +1255,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 +1265,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 +1294,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 +1323,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 +1332,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 +1382,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 +1406,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 +1579,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 @@ -1719,107 +1674,73 @@ 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) + (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) (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 'paren-backwards-message) 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) + (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) (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 'vc-header-alist) + `((SCCS ,(car cperl-vc-sccs-header)) + (RCS ,(car cperl-vc-rcs-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 +1755,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)) + (setq 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 + (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 +1779,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 +1879,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 +1932,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 +2004,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 +2040,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 +2051,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 +2075,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 +2088,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 +2127,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 +2202,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 +2221,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 +2260,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 +2360,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 +2528,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 +2558,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 +2577,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 +2612,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 +2792,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 +2869,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 +2909,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 +2931,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 +3099,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") @@ -3442,8 +3357,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 +3378,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 +3416,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 +3431,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 @@ -3618,7 +3532,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 +3551,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 +3661,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 +3674,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__ @@ -3834,7 +3749,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 +3762,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 +3872,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 +4056,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)) @@ -4539,7 +4454,7 @@ 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 [] +;;; POSIX? [:word:] [:^word:] only inside [] ;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]") (while ; look for unescaped ] (and argument @@ -4797,8 +4712,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 +4732,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 +4761,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 +4781,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 +4856,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 +4885,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 +4921,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" "\\|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 @@ -5097,7 +5012,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 +5021,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 +5031,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 +5152,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 +5169,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 +5182,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 +5367,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 +5516,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 +5539,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 +5590,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 +5612,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 +5642,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 +5653,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 +5671,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 +5684,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 +5714,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) "\\(" @@ -5834,14 +5756,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 +5772,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 +5820,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 +5951,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 +6016,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 +6055,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 +6137,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 +6384,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 +6406,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 +6439,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 +6470,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 +6568,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 +6596,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 +6647,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 +6702,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 +6740,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 +6758,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 +6777,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 +6817,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 +6836,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 +6876,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) @@ -7038,7 +6934,7 @@ Use as (setq topdir default-directory)) (let ((tags-file-name "TAGS") (case-fold-search (and (featurep 'xemacs) (eq system-type 'emx))) - xs rel tm) + xs rel) (save-excursion (cond (inbuffer nil) ; Already there ((file-exists-p tags-file-name) @@ -7053,7 +6949,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 +6957,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 +7007,7 @@ Use as "^\\(" "\\(package\\)\\>" "\\|" - "sub\\>[^\n]+::" + cperl-sub-regexp "\\>[^\n]+::" "\\|" "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB? "\\|" @@ -7127,10 +7024,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,7 +7078,7 @@ 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 @@ -7216,10 +7112,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 +7131,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 +7171,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 +7197,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 +7223,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 +7241,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 +7249,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) @@ -7372,6 +7266,7 @@ One may build such TAGS files from CPerl mode menu." "\\$." ; $| "<<[a-zA-Z_'\"`]" ; <<FOO, <<'FOO' "||" + "//" "&&" "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value @@ -7393,22 +7288,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 +7311,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,7 +7340,7 @@ 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 @@ -7545,7 +7440,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 +7607,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 +7645,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 +7653,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 +7669,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 +7686,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 +7723,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 +7784,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 +7819,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 +7855,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 +7876,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 +7888,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 +7911,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 +7935,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) @@ -8223,8 +8131,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)) @@ -8301,7 +8209,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 +8421,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." @@ -8544,6 +8452,8 @@ the appropriate statement modifier." (manual-program (if is-func "perldoc -f" "perldoc"))) (cond ((featurep 'xemacs) + (defvar Manual-program) + (defvar Manual-switches) (let ((Manual-program "perldoc") (Manual-switches (if is-func (list "-f")))) (manual-entry word))) @@ -8561,7 +8471,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,13 +8488,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) + (defvar Manual-program) (let ((Manual-program "perldoc")) (manual-entry buffer-file-name))) (t @@ -8641,7 +8552,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 +8561,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 +8610,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 +8646,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 +8659,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) @@ -8811,61 +8722,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 +8799,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 +8860,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 6cd02da8f52..432be1aaad8 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." diff --git a/lisp/progmodes/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el index 1ed07ba17bb..66f1d398df4 100644 --- a/lisp/progmodes/ebnf-abn.el +++ b/lisp/progmodes/ebnf-abn.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2001-2018 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> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.2 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el index 7fe61cd626e..7defe9877b2 100644 --- a/lisp/progmodes/ebnf-bnf.el +++ b/lisp/progmodes/ebnf-bnf.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2018 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> +;; Maintainer: 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 c0dbc9e3308..2dec3f9159b 100644 --- a/lisp/progmodes/ebnf-dtd.el +++ b/lisp/progmodes/ebnf-dtd.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2001-2018 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> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.1 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el index bbaba13e688..0dc82fc3bff 100644 --- a/lisp/progmodes/ebnf-ebx.el +++ b/lisp/progmodes/ebnf-ebx.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2001-2018 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> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.2 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el index c6ebc8d3969..06aaf8a3f55 100644 --- a/lisp/progmodes/ebnf-iso.el +++ b/lisp/progmodes/ebnf-iso.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2018 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> +;; Maintainer: 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 3affbcc41d7..5857aa306ba 100644 --- a/lisp/progmodes/ebnf-otz.el +++ b/lisp/progmodes/ebnf-otz.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2018 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> +;; Maintainer: 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 894c9dd9d79..eac0bfc878a 100644 --- a/lisp/progmodes/ebnf-yac.el +++ b/lisp/progmodes/ebnf-yac.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2018 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> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.4 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el index 40d6af9e654..74ec569214e 100644 --- a/lisp/progmodes/ebnf2ps.el +++ b/lisp/progmodes/ebnf2ps.el @@ -1,9 +1,9 @@ -;;; 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-2018 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> +;; Maintainer: 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 +30,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 +1153,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 +2047,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 +2251,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 +2382,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 +2411,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 +2611,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 +4000,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 +4277,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 +4293,14 @@ end %%EndProlog " - "EBNF EPS begin") + "EBNF EPS begin.") (defconst ebnf-eps-end "#ebnf2ps#end %%EOF " - "EBNF EPS end") + "EBNF EPS end.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -4329,14 +4330,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 +4539,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 +4575,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 +4587,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 +4606,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 +4643,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 +4655,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) @@ -5314,9 +5310,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 +5541,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 +5921,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 c9557900190..07b58b53823 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -1107,7 +1107,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) @@ -4023,7 +4023,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) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 8fe6ef0550b..935e55c5d70 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -901,10 +901,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 +914,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 +940,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 +1132,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 +1167,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 diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index a31668e1baa..4f07fe94855 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -274,12 +274,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 @@ -439,25 +436,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 +467,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 @@ -2060,7 +2059,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." diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el index 2105377a165..c3e085dda5b 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 @@ -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..ebcfd7d1f6e --- /dev/null +++ b/lisp/progmodes/flymake-cc.el @@ -0,0 +1,140 @@ +;;; flymake-cc.el --- Flymake support for GNU tools for C/C++ -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 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)) + (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)) + 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" "CHK_SOURCES=-x 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) + (when (eq 'exit (process-status p)) + (unwind-protect + (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)))))))) + ;; (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 4792a945308..8600be9b97c 100644 --- a/lisp/progmodes/flymake-proc.el +++ b/lisp/progmodes/flymake-proc.el @@ -3,8 +3,8 @@ ;; Copyright (C) 2003-2018 Free Software Foundation, Inc. ;; Author: Pavel Kobyakov <pk_at_work@yahoo.com> -;; Maintainer: Leo Liu <sdl.web@gmail.com> -;; Version: 0.3 +;; 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) @@ -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 40eacdd1888..fdb22ccaf34 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -3,8 +3,8 @@ ;; Copyright (C) 2003-2018 Free Software Foundation, Inc. ;; Author: Pavel Kobyakov <pk_at_work@yahoo.com> -;; Maintainer: Leo Liu <sdl.web@gmail.com> -;; Version: 0.3 +;; Maintainer: João Távora <joaotavora@gmail.com> +;; Version: 1.0 ;; Keywords: c languages tools ;; This file is part of GNU Emacs. @@ -34,13 +34,77 @@ ;; 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-syntax-check-on-newline' and +;; `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: @@ -132,11 +196,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) @@ -222,18 +292,21 @@ generated it." (cl-defstruct (flymake--diag (:constructor flymake--diag-make)) - buffer beg end type text backend) + buffer beg end type text backend data) ;;;###autoload (defun flymake-make-diagnostic (buffer beg end type - text) + text + &optional data) "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." + (flymake--diag-make :buffer buffer :beg beg :end end + :type type :text text :data data)) ;;;###autoload (defun flymake-diagnostics (&optional beg end) @@ -257,6 +330,7 @@ diagnostics at BEG." (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) (cl-defun flymake--overlays (&key beg end filter compare key) "Get flymake-related overlays. @@ -419,74 +493,63 @@ Currently accepted REPORT-KEY arguments are: * `: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.") +(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 +566,38 @@ associated `flymake-category' return DEFAULT." (list bitmap))))))) (defun flymake--highlight-line (diagnostic) - "Highlight buffer with info in DIAGNOSTIC." - (when-let* ((ov (make-overlay + "Highlight buffer with info in DIGNOSTIC." + (when-let* ((type (flymake--diag-type diagnostic)) + (ov (make-overlay (flymake--diag-beg diagnostic) (flymake--diag-end diagnostic)))) - ;; First set `category' in the overlay, then copy over every other - ;; property. + ;; 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 ; 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 @@ -818,7 +885,9 @@ The commands `flymake-goto-next-error' and 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 @@ -899,7 +968,7 @@ Do it only if `flymake-no-changes-timeout' is non-nil." (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 +991,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 +1007,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 +1036,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 +1050,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)) @@ -1063,12 +1135,10 @@ applied." (cl-loop for (type . severity) in (cl-sort (mapcar (lambda (type) - (cons type (flymake--lookup-type-property - type - 'severity - (warning-numeric-level :error)))) + (cons type (flymake--severity type))) (cl-union (hash-table-keys diags-by-type) - '(:error :warning))) + '(:error :warning) + :key #'flymake--severity)) #'> :key #'cdr) for diags = (gethash type diags-by-type) diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index 3fddf2392ea..bfbf6c09b27 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -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)))) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 32d5ced67d0..88e34d8df9f 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).") @@ -2717,10 +2717,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 "}"))) diff --git a/lisp/progmodes/glasses.el b/lisp/progmodes/glasses.el index de176019a57..c3e8ac35f32 100644 --- a/lisp/progmodes/glasses.el +++ b/lisp/progmodes/glasses.el @@ -326,10 +326,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 da09c900e58..b7c44d60838 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. @@ -433,6 +428,28 @@ 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) + +(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\\)\\)$" @@ -450,9 +467,18 @@ See `compilation-error-regexp-alist' for format details.") (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.") @@ -1046,6 +1072,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)))))) @@ -1168,6 +1195,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 9cf818e99ea..6826674a942 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)))) @@ -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).") @@ -1605,7 +1606,7 @@ 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)?()" (defvar gud-pdb-marker-regexp - "^> \\([-a-zA-Z0-9_/.:\\]*\\|<string>\\)(\\([0-9]+\\))\\([a-zA-Z0-9_]*\\|\\?\\|<module>\\)()\\(->[^\n\r]*\\)?[\n\r]") + "^> \\([-a-zA-Z0-9_/.:@ \\]*\\|<string>\\)(\\([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) @@ -2604,7 +2605,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. @@ -3395,9 +3401,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 +3408,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 +3499,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)) diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el index cbdca015e93..54e740be11f 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/progmodes/idlw-help.el @@ -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 1b72eea09eb..dcb81f5a944 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -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) @@ -2261,12 +2261,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) @@ -3597,7 +3597,7 @@ Existing overlays are recycled, in order to minimize consumption." (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 diff --git a/lisp/progmodes/idlw-toolbar.el b/lisp/progmodes/idlw-toolbar.el index 7595db98230..75f55827933 100644 --- a/lisp/progmodes/idlw-toolbar.el +++ b/lisp/progmodes/idlw-toolbar.el @@ -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 1d5dc7c7948..540931c9f2f 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -151,7 +151,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'idlw-help) ;; For XEmacs @@ -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)))) @@ -6223,7 +6223,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) @@ -6520,7 +6520,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]*\\=" @@ -8190,7 +8190,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 +8399,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 +8707,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 +8776,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)) diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 02512ae2de1..f30e591b15a 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -3870,7 +3870,6 @@ If one hasn't been set, or if it's stale, prompt for a new one." (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 diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index a1a66c09c63..f67407f48ee 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -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/octave.el b/lisp/progmodes/octave.el index c768d8d6f4d..984bb73c73e 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -639,6 +639,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 +696,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. @@ -1165,6 +1165,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 diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el index 737dd9ea8a8..58dc213d8af 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -1403,7 +1403,6 @@ 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, diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index c9bfb1acdfe..b96aad7a6ef 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) @@ -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/python.el b/lisp/progmodes/python.el index c7bb2d97c84..6f4a343310c 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 @@ -636,15 +647,15 @@ The type returned can be `comment', `string' or `paren'." ((python-rx string-delimiter) (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 @@ -1474,7 +1485,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 +1500,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) @@ -1508,7 +1520,8 @@ of the statement." ;; narrowing. (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. @@ -2147,7 +2160,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))) @@ -2829,10 +2842,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. @@ -2910,11 +2925,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 @@ -2930,12 +2951,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) @@ -3150,9 +3165,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) @@ -3183,10 +3201,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 @@ -5191,9 +5209,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) @@ -5286,6 +5305,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" @@ -5381,7 +5401,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 5abc29a6645..1f5d8865a73 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-" diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index a4cb4856a84..aaa86b5816f 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -2392,7 +2392,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))) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index e7d7494d2ca..63428610a59 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -344,7 +344,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 @@ -691,6 +692,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 +706,6 @@ This allows highlighting buffers properly when you open them." sql-product-alist)) :group 'SQL :safe 'symbolp) -(defvaralias 'sql-dialect 'sql-product) ;; misc customization of sql.el behavior @@ -759,16 +761,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 +794,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 @@ -1103,8 +1109,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)))) @@ -1236,8 +1245,8 @@ specified, it's `sql-product' or `sql-connection' must match." (and (derived-mode-p 'sql-interactive-mode) (or (not product) (eq product sql-product)) - (or (not connection) - (eq connection sql-connection))))))) + (or (stringp connection) + (string= connection sql-connection))))))) ;; Keymap for sql-interactive-mode. @@ -2712,18 +2721,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 @@ -2760,8 +2803,8 @@ local variable." (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) @@ -2952,7 +2995,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 +3020,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 +3039,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)) @@ -3129,7 +3181,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,7 +3203,7 @@ 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 @@ -3198,6 +3250,34 @@ 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 (when (stringp base) + (substring-no-properties + (or base + (sql-get-product-feature product :name) + (symbol-name product))))) + buf-fmt-1st buf-fmt-rest) + + ;; Calculate buffer format + (if base-name + (setq buf-fmt-1st (format "*SQL: %s*" base-name) + buf-fmt-rest (format "*SQL: %s-%%d*" base-name)) + (setq buf-fmt-1st "*SQL*" + buf-fmt-rest "*SQL-%d*")) + + ;; See if we can find an unused buffer + (let ((buf-name buf-fmt-1st) + (i 1)) + (while (sql-buffer-live-p 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 +3293,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. @@ -3439,15 +3521,14 @@ to avoid deleting non-prompt output." (sql-input-sender (get-buffer-process sql-buffer) s) ;; Send a command terminator if we must - (if sql-send-terminator - (sql-send-magic-terminator sql-buffer s sql-send-terminator)) + (when 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")))) @@ -3546,15 +3627,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 +3691,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 +3706,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 @@ -4031,15 +4119,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))))) @@ -4215,31 +4304,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 +4339,37 @@ 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))) + + ;; 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)))) + ((or (string-prefix-p " " new-name) + (string-match-p "\\`[*].*[*]\\'" new-name)) + new-name) + ((stringp new-name) + (sql-generate-unique-sqli-buffer-name product new-name)) (t - (format "*SQL: %s*" new-name))))) + (sql-generate-unique-sqli-buffer-name product nil))))) ;; Set SQLi mode. (let ((sql-interactive-product product)) @@ -4306,25 +4397,26 @@ the call to \\[sql-product-interactive] with (<= 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 +4429,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 +4513,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]." diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 48dee4bef31..66577619028 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -3966,7 +3966,9 @@ Key bindings specific to `verilog-mode-map' are: #'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 ) diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index a841f87f3c3..f6cb2419de8 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -4953,8 +4953,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)) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index b0bdd62ae98..9a437b6f690 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -501,8 +501,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 @@ -539,9 +540,11 @@ 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) + (let ((buffer (current-buffer)) + (xref (or (xref--item-at-point) (user-error "No reference at point")))) - (xref--show-location (xref-item-location xref) (if quit 'quit t)))) + (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." diff --git a/lisp/ps-def.el b/lisp/ps-def.el index 9fbb83a74bc..d0cd7625a41 100644 --- a/lisp/ps-def.el +++ b/lisp/ps-def.el @@ -2,10 +2,10 @@ ;; Copyright (C) 2007-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; 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> ;; Keywords: wp, print, PostScript ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre ;; Package: ps-print @@ -31,9 +31,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)) diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el index a102d974a46..ae2dd19d2fa 100644 --- a/lisp/ps-mule.el +++ b/lisp/ps-mule.el @@ -2,10 +2,10 @@ ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; 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> ;; Keywords: wp, print, PostScript, multibyte, mule ;; Package: ps-print diff --git a/lisp/ps-print.el b/lisp/ps-print.el index b1a911724f0..28f93f4e203 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -4,10 +4,10 @@ ;; Author: Jim Thompson (was <thompson@wg2.waii.com>) ;; Jacques Duthen (was <duthen@cegelec-red.fr>) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; 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> ;; Keywords: wp, print, PostScript ;; Version: 7.3.5 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre @@ -20,7 +20,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. @@ -1216,7 +1216,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 +1274,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 +1287,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. @@ -1773,7 +1773,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 @@ -4140,48 +4140,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 @@ -6350,10 +6308,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 9c545ea8537..bd5fff8d8ec 100644 --- a/lisp/ps-samp.el +++ b/lisp/ps-samp.el @@ -4,10 +4,10 @@ ;; Author: Jim Thompson (was <thompson@wg2.waii.com>) ;; Jacques Duthen (was <duthen@cegelec-red.fr>) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; 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> ;; 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 b33f22d9598..c3c4e459222 100644 --- a/lisp/recentf.el +++ b/lisp/recentf.el @@ -228,10 +228,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 diff --git a/lisp/register.el b/lisp/register.el index fa34e608592..77d84c047a9 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 @@ -242,36 +244,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 +363,84 @@ 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)) + (princ "a window configuration.")) + + ((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 +456,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 95097a4f1b7..4928dd9b202 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) - (cdr (memq (car entry-key) precious)))) + (cdr (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 940bf566509..20b868a765c 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) @@ -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)))))) + (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)) + 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 @@ -1192,7 +1222,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 +1235,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 +1272,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 +1289,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)) @@ -1387,9 +1414,8 @@ invoke `occur'." ;; 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--region-start-line nil) (defvar occur--orig-line nil) -(defvar occur--orig-line-str nil) (defvar occur--final-pos nil) (defun occur (regexp &optional nlines region) @@ -1442,17 +1468,15 @@ is not modified." (or end (setq end (point-max)))) (let ((occur--region-start start) (occur--region-end end) - (occur--matches-threshold + (occur--region-start-line (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)))) + (line-number-at-pos (point)))) (save-excursion ; If no matches `occur-1' doesn't restore the point. - (and in-region-p (narrow-to-region start end)) + (and in-region-p (narrow-to-region + (save-excursion (goto-char start) (line-beginning-position)) + (save-excursion (goto-char end) (line-end-position)))) (occur-1 regexp nlines (list (current-buffer))) (and in-region-p (widen)))))) @@ -1550,7 +1574,7 @@ 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) @@ -1618,36 +1642,34 @@ See also `multi-occur'." (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))) + (in-region-p (and occur--region-start occur--region-end)) + (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) + (or occur--region-start-line 1)) + (orig-line occur--orig-line) + (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)) + ;; 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. @@ -1677,6 +1699,16 @@ 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)) + (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)) @@ -1703,9 +1735,9 @@ See also `multi-occur'." ;; 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, @@ -1725,7 +1757,7 @@ See also `multi-occur'." "\n" (if prefix-face (propertize - "\n :" 'font-lock-face prefix-face) + "\n :" 'font-lock-face prefix-face) "\n :") match-str) ;; Add marker at eol, but no mouse props. @@ -1737,26 +1769,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 (- orig-line (or occur--region-start-line 1))) + (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) - (>= 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 @@ -1765,29 +1804,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)) - (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 (- orig-line (or occur--region-start-line 1))) + (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)) @@ -1803,25 +1847,28 @@ See also `multi-occur'." (if (= lines matches) "" (format " in %d line%s" lines - (if (= lines 1) "" "s"))) + (if (= lines 1) "" "s"))) ;; 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) - "")) + (if in-region-p + (format " within region: %d-%d" + occur--region-start + occur--region-end) + "")) '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)) @@ -1895,7 +1942,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 @@ -1905,13 +1953,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) @@ -2184,9 +2251,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 @@ -2216,7 +2283,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 @@ -2277,7 +2347,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)))) @@ -2322,8 +2397,17 @@ 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) ") + (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. @@ -2541,13 +2625,13 @@ It must return a string." (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 " "") - (if backward "backward " "") from-string " with " next-replacement ".\n\n" (substitute-command-keys diff --git a/lisp/rtree.el b/lisp/rtree.el index 71ee0a13b90..ee2fca612f5 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-2018 Free Software Foundation, Inc. @@ -43,9 +43,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - (defmacro rtree-make-node () `(list (list nil) nil)) @@ -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 2e2a589ecf1..02d5a211ba7 100644 --- a/lisp/ruler-mode.el +++ b/lisp/ruler-mode.el @@ -709,20 +709,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 fbb5f533902..0a261b0b0ca 100644 --- a/lisp/savehist.el +++ b/lisp/savehist.el @@ -204,29 +204,6 @@ 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. diff --git a/lisp/select.el b/lisp/select.el index 698be837547..bd7fd0c1ffa 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -86,6 +86,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 +96,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 +106,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 diff --git a/lisp/server.el b/lisp/server.el index ac0d7018513..ff03cbe622c 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -188,6 +188,13 @@ space (this means characters from ! to ~; or from code 33 to :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." + :group 'server + :type 'hook + :version "27.1") + (defcustom server-done-hook nil "Hook run when done editing a buffer for the Emacs server." :group 'server @@ -251,8 +258,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,8 +278,10 @@ changed while a server is running." ;; 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)) + (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.") @@ -618,23 +635,29 @@ To force-start a server, do \\[server-force-delete] and then (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))) @@ -1061,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. @@ -1077,7 +1099,8 @@ 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 @@ -1229,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 @@ -1262,7 +1286,7 @@ 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)) @@ -1271,7 +1295,7 @@ The following commands are accepted by the client: ;; condition-case (error (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 @@ -1281,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)) + (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 (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)))))) - ;; 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))) + (mapc 'funcall (nreverse commands)) ;; Delete the client if necessary. (cond @@ -1311,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 diff --git a/lisp/ses.el b/lisp/ses.el index 9097bf5d819..bcf8bdb6368 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -2495,7 +2495,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 +2648,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))) diff --git a/lisp/shell.el b/lisp/shell.el index 5c228a5eba9..232186083d5 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -315,6 +315,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.") @@ -568,8 +570,10 @@ 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)))))) + (let ((shell (if (get-buffer-process (current-buffer)) + (file-name-nondirectory + (car (process-command (get-buffer-process (current-buffer))))) + "")) (hsize (getenv "HISTSIZE"))) (and (stringp hsize) (integerp (setq hsize (string-to-number hsize))) @@ -959,7 +963,6 @@ 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 diff --git a/lisp/simple.el b/lisp/simple.el index cbad75193a4..f8c02c1dbfe 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 @@ -144,6 +122,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 +177,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 +234,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 +263,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 +271,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 +294,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 +307,51 @@ 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) + (next-error-found buffer (current-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))) + (next-error-found buffer (current-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 +362,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)))) @@ -1103,6 +1161,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 @@ -1588,13 +1647,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) @@ -1624,13 +1680,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)))) @@ -1847,11 +1900,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. @@ -2941,7 +2991,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 @@ -2990,10 +3040,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. @@ -3006,30 +3056,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 @@ -3142,61 +3200,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. @@ -3296,6 +3299,28 @@ is output." :group 'shell :version "26.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'." @@ -3376,6 +3401,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. @@ -3453,12 +3480,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 @@ -3466,24 +3492,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, @@ -3502,12 +3526,11 @@ 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) @@ -3539,14 +3562,14 @@ 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)) + (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))) @@ -3846,7 +3869,7 @@ 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. @@ -3929,7 +3952,9 @@ 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) ("Command" 0 t)]) (make-local-variable 'process-menu-query-only) @@ -4363,7 +4388,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))) @@ -4372,9 +4398,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))) @@ -4397,20 +4422,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. @@ -4444,9 +4469,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")) @@ -5683,22 +5712,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)) @@ -5710,10 +5740,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 @@ -7859,7 +7889,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) @@ -7877,6 +7907,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))) @@ -8520,13 +8552,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)) @@ -8951,7 +8986,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) @@ -8961,7 +8996,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) diff --git a/lisp/skeleton.el b/lisp/skeleton.el index 90e3819cb7f..1d1af825a17 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/speedbar.el b/lisp/speedbar.el index 7915a52df3a..48829d4023f 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -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. @@ -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. @@ -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 33f8ca63f8d..245b9ac5ba4 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -63,6 +63,9 @@ string or function value that this variable has." :version "23.1" :group 'initialization) +(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. @@ -71,9 +74,6 @@ 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) - (defvar startup-screen-inhibit-startup-screen nil) ;; The mechanism used to ensure that only end users can disable this @@ -120,18 +120,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 +314,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 @@ -789,7 +797,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 +886,92 @@ If STYLE is nil, display appropriately for the terminal." (when standard-display-table (aset standard-display-table char nil))))))) +(defun 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 init-file-name 'noerror 'nomessage) + + (when (and (eq user-init-file t) alternate-filename-function) + (load (funcall alternate-filename-function) + '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 command-line () "A subroutine of `normal-top-level'. Amongst another things, it parses the command-line arguments." @@ -1029,6 +1123,78 @@ 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 + (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)))) + + ;; 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. + (load-user-init-file + (lambda () + (expand-file-name + "early-init" + (file-name-as-directory + (concat "~" init-file-user "/.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,15 +1262,6 @@ 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. - (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)))) - (normal-erase-is-backspace-setup-frame) ;; Register default TTY colors for the case the terminal hasn't a @@ -1130,176 +1287,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))) + (load-user-init-file + (lambda () + (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"))) + (lambda () + (expand-file-name + "init" + (file-name-as-directory + (concat "~" init-file-user "/.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 +1354,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 @@ -2505,7 +2511,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) @@ -2518,7 +2529,7 @@ nil default-directory" name) (error "initial-buffer-choice must be a string, a function, or t."))))) (unless (buffer-live-p buf) (error "initial-buffer-choice is not a live buffer.")) - (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/subr.el b/lisp/subr.el index f8ac70edefa..914112ccef5 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -78,8 +78,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) @@ -223,7 +223,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)) @@ -680,20 +680,6 @@ 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. @@ -705,21 +691,29 @@ Non-strings in LIST are ignored." (setq list (cdr list))) list) -(defun assq-delete-all (key alist) - "Delete from ALIST all elements whose car is `eq' 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)) - (eq (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)) - (eq (car (car tail-cdr)) key)) + (funcall test (caar tail-cdr) key)) (setcdr tail (cdr tail-cdr)) (setq tail tail-cdr)))) alist) +(defun assq-delete-all (key alist) + "Delete from ALIST all elements whose car is `eq' to KEY. +Return the modified alist. +Elements of ALIST that are not conses are ignored." + (assoc-delete-all key alist #'eq)) + (defun rassq-delete-all (value alist) "Delete from ALIST all elements whose cdr is `eq' to VALUE. Return the modified alist. @@ -1440,8 +1434,17 @@ 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") ;; 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") @@ -1453,17 +1456,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. @@ -1481,15 +1480,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, @@ -1813,7 +1803,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))) @@ -1829,27 +1819,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.") @@ -1878,15 +1866,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 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'. @@ -2162,19 +2157,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)))) @@ -2575,7 +2557,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. @@ -2598,8 +2580,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 @@ -3597,6 +3579,119 @@ 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 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." @@ -4238,14 +4333,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) @@ -4530,10 +4635,10 @@ 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 "()"))) + (cl-prin1 func) + (if args (cl-prin1 args) (princ "()"))) (t - (prin1 (cons func args)))) + (cl-prin1 (cons func args)))) (princ "\n")) (defun backtrace () diff --git a/lisp/svg.el b/lisp/svg.el index c0fa26ade03..1178905546a 100644 --- a/lisp/svg.el +++ b/lisp/svg.el @@ -157,7 +157,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) diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 07d902c1bb0..f7b14fab516 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -265,11 +265,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 @@ -596,7 +595,7 @@ 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"))) @@ -907,8 +906,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) diff --git a/lisp/term.el b/lisp/term.el index 419ddb2db5c..9aa4a20e36e 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-2018 Free Software ;; Foundation, Inc. @@ -101,12 +101,8 @@ ;; ---------------------------------------- ;; ;; -;; 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. ;; ;; ---------------------------------------- ;; @@ -395,21 +391,14 @@ 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. @@ -596,9 +585,6 @@ 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'." @@ -756,12 +742,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 @@ -1083,8 +1063,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) @@ -1097,15 +1075,9 @@ 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) @@ -1520,6 +1492,31 @@ Using \"emacs\" loses, because bash disables editing if $TERM == emacs.") ;; don't define :te=\\E[2J\\E[?47l\\E8:ti=\\E7\\E[?47h\ "Termcap capabilities supported.") +;; This private hack is for backwards compatibility with Bash 4.3 and earlier. +;; It can be useful even when running a program other than Bash, as the +;; program might invoke Bash as an interactive subshell. See this thread: +;; https://lists.gnu.org/r/emacs-devel/2018-05/msg00670.html +;; Remove this hack and its uses once Bash 4.4-or-later is reasonably +;; universal, because it slows down execution slightly when +;; term--bash-needs-EMACSp is first called. +(defvar term--bash-needs-EMACS-status nil + "43 if Bash is so old that it needs EMACS set. +Some other integer if Bash is new or not in use. +Nil if unknown.") +(defun term--bash-needs-EMACSp () + "t if Bash is old, nil if it is new or not in use." + (eq 43 + (or term--bash-needs-EMACS-status + (setf + term--bash-needs-EMACS-status + (let ((process-environment + (cons "BASH_ENV" process-environment))) + (condition-case nil + (call-process + "bash" nil nil nil "-c" + "case $BASH_VERSION in [0123].*|4.[0123].*) exit 43;; esac") + (error 0))))))) + ;; This auxiliary function cranks up the process for term-exec in ;; the appropriate environment. @@ -1537,12 +1534,6 @@ Using \"emacs\" loses, because bash disables editing if $TERM == emacs.") (format term-termcap-format "TERMCAP=" term-term-name term-height term-width) - ;; This is for backwards compatibility with Bash 4.3 and earlier. - ;; Remove this hack once Bash 4.4-or-later is common, because - ;; it breaks './configure' of some packages that expect it to - ;; say where to find EMACS. - (format "EMACS=%s (term:%s)" emacs-version term-protocol-version) - (format "INSIDE_EMACS=%s,term:%s" emacs-version term-protocol-version) (format "LINES=%d" term-height) (format "COLUMNS=%d" term-width)) @@ -1554,6 +1545,9 @@ Using \"emacs\" loses, because bash disables editing if $TERM == emacs.") ;; escape codes, so we need to see the raw output. We will have to ;; do the decoding by hand on the parts that are made of chars. (coding-system-for-read 'binary)) + (when (term--bash-needs-EMACSp) + (push (format "EMACS=%s (term:%s)" emacs-version term-protocol-version) + process-environment)) (apply 'start-process name buffer "/bin/sh" "-c" (format "stty -nl echo rows %d columns %d sane 2>/dev/null;\ @@ -2672,10 +2666,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 @@ -2684,6 +2676,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))) @@ -2716,11 +2713,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. @@ -2771,11 +2763,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) @@ -2783,27 +2770,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)) @@ -2833,298 +2835,220 @@ 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 (eq (char-charset (aref decoded-substring - (- count 1 partial))) - 'eight-bit) - (cl-incf partial)) - (when (> 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 (eq (char-charset (aref decoded-substring + (- count 1 partial))) + 'eight-bit) + (cl-incf partial)) + (when (> 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))) + (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-hook + (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))) + (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 ctl-end))))) (when (>= (term-current-row) term-height) (term-handle-deferred-scroll)) @@ -3355,87 +3279,83 @@ 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 (1- term-scroll-end)) (term-down - (if (> (+ tcr term-terminal-parameter) term-scroll-end) + (if (> (+ tcr scroll-amount) term-scroll-end) (- term-scroll-end 1 tcr) - (max 1 term-terminal-parameter)) t)))) + (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)) )) @@ -3443,15 +3363,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) @@ -3464,8 +3376,8 @@ 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-set-scroll-region (top bottom) @@ -3653,7 +3565,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)) @@ -3831,7 +3743,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)))) diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el index 5df635a145d..6ef686a996f 100644 --- a/lisp/term/common-win.el +++ b/lisp/term/common-win.el @@ -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 2cf560694c6..0cdf0c1a7c3 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 76b1a414560..8b23cab0100 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 () @@ -556,8 +553,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 +573,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) @@ -739,6 +743,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) @@ -801,8 +809,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 62734d9cfe4..e0e412e1626 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 b3e70f3107b..34ed492c872 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/w32-win.el b/lisp/term/w32-win.el index ed76490751e..dc57160d04f 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) @@ -276,7 +276,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(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 @@ -309,7 +310,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 @@ -391,8 +392,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 e3196ab84e3..f169b27bc47 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 9209a76fcdc..b3b7a216352 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,42 @@ 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) + (handle-focus-in) + []) + +(defun xterm-translate-focus-out (_prompt) + (handle-focus-out) + []) + +;; 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 +159,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 +672,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 +700,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 +750,24 @@ 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 (float-time))) + (or (let ((inhibit-redisplay t)) + (read-event nil nil xterm-query-redisplay-timeout)) + (read-event nil nil + (and xterm-query-timeout + (max 0 (+ start-time xterm-query-timeout + (- (float-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 +800,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 +863,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 +885,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 +899,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") diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index af7bcc77cdf..61ca0856bc9 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -351,13 +351,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'." @@ -1401,7 +1400,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 () diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index efab9d8e3bd..50a30cf6c36 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. @@ -2343,7 +2345,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 +2368,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 +2936,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 +3643,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 +3850,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 +3875,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 +4065,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 +4113,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) @@ -4925,23 +4936,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. diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index febf7c66139..6d06dddadca 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -32,12 +32,14 @@ ;;; Code: -(require 'eww) (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 @@ -808,6 +810,7 @@ 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) + (define-key map "\C-c\C-f" 'css-cycle-color-format) map) "Keymap used in `css-mode'.") @@ -898,7 +901,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 "\\)\\|" @@ -938,11 +941,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) @@ -952,11 +957,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) @@ -968,7 +973,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. @@ -1039,9 +1048,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. @@ -1203,7 +1218,8 @@ for determining whether point is within a selector." (pcase (cons kind token) (`(:elem . basic) css-indent-offset) (`(:elem . arg) 0) - (`(:list-intro . ,(or `";" `"")) t) ;"" stands for BOB (bug#15467). + ;; "" stands for BOB (bug#15467). + (`(:list-intro . ,(or `";" `"" `":-property")) t) (`(:before . "{") (when (or (smie-rule-hanging-p) (smie-rule-bolp)) (smie-backward-sexp ";") @@ -1385,6 +1401,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 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). @@ -1420,7 +1601,13 @@ Network (MDN). (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) @@ -1517,12 +1704,8 @@ Network (MDN). (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 7223d525fa2..87ae35d17be 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) diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el index b9d247132dc..6b4c44a39e7 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")) @@ -492,6 +494,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 8422f0e1dd2..08e975f2355 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 24e424c663c..9747f8e2ebf 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -321,14 +321,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) @@ -982,6 +984,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) diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 2b88057dc4f..73a2c2da8b1 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -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) @@ -1202,8 +1205,9 @@ Internal use.") (with-output-to-string (with-current-buffer standard-output - (apply 'ispell-call-process - (concat ispell-program-name "-lsmod") 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. @@ -1826,11 +1830,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) diff --git a/lisp/textmodes/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el index b99f788156c..552fcd38b04 100644 --- a/lisp/textmodes/mhtml-mode.el +++ b/lisp/textmodes/mhtml-mode.el @@ -22,6 +22,7 @@ ;;; Code: (eval-and-compile + (require 'cl-lib) (require 'flyspell) (require 'sgml-mode)) (require 'js) @@ -364,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 9c846292f1e..6955ed25e18 100644 --- a/lisp/textmodes/nroff-mode.el +++ b/lisp/textmodes/nroff-mode.el @@ -328,13 +328,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 61f02190065..92fce4d364b 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-2018 Free Software ;; Foundation, Inc. @@ -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,23 +259,19 @@ (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 @@ -311,19 +304,21 @@ With arg (prefix if interactive), move that many pages." (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)) @@ -415,9 +410,9 @@ Point is left in the body of page." 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 @@ -463,25 +458,27 @@ 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-m" '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 [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" "Default page delimiter.") @@ -512,6 +509,9 @@ resets the page-delimiter to the original value." ;;; 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 +573,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 +643,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 +696,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 +716,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 diff --git a/lisp/textmodes/reftex-ref.el b/lisp/textmodes/reftex-ref.el index 98fb8f5d700..eb8d98c84be 100644 --- a/lisp/textmodes/reftex-ref.el +++ b/lisp/textmodes/reftex-ref.el @@ -314,7 +314,7 @@ also applies `reftex-translate-to-ascii-function' to the string." (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/remember.el b/lisp/textmodes/remember.el index 7f4c9b0b24a..83bfc79d6a4 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 b1b4f1073eb..40d75a9db84 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) @@ -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) @@ -1503,8 +1484,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 +1520,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 +1536,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 +1974,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 +1982,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 +2404,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 +2640,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 +2654,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 +3128,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 +3601,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 +3615,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 +3629,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 +3645,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 +3659,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 +3673,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 +3686,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 +3700,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 +3714,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 +3796,6 @@ of your own." (const :tag "transitions" t) (const :tag "section title adornment" nil)) :value-type (face))) -(rst-testcover-defcustom) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -4337,7 +4292,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 eb6ebf52807..30ca11199d4 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -76,6 +76,8 @@ a DOCTYPE or an XML declaration." :version "22.1" :group 'sgml) +(defvaralias 'sgml-transformation 'sgml-transformation-function) + (defcustom sgml-transformation-function 'identity "Default value for `skeleton-transformation-function' in SGML mode." :type 'function @@ -92,7 +94,6 @@ a DOCTYPE or an XML declaration." (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'. @@ -618,7 +619,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 `/'. @@ -1241,8 +1242,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) @@ -1250,14 +1254,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][0-9a-fA-F]+\\)\\)\\)\\([][<>&;\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) @@ -2232,6 +2245,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'." diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el index d6f451a1ab5..e89da6527cb 100644 --- a/lisp/textmodes/texinfmt.el +++ b/lisp/textmodes/texinfmt.el @@ -2447,7 +2447,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 c2ceee6e6b7..ff723a4fb94 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -596,9 +596,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 +610,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. diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 7fe99b0714c..4612e95bb0e 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) @@ -237,21 +240,28 @@ The bounds of THING are determined by `bounds-of-thing-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 diff --git a/lisp/time.el b/lisp/time.el index 9e7bd08b85a..ab6b5b96328 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -585,7 +585,7 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\"." (let ((str (format-seconds (or format "%Y, %D, %H, %M, %z%S") (float-time - (time-subtract (current-time) before-init-time))))) + (time-subtract nil before-init-time))))) (if (called-interactively-p 'interactive) (message "%s" str) str))) diff --git a/lisp/tooltip.el b/lisp/tooltip.el index ac26f86ac9d..81df229a132 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -155,6 +155,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. @@ -347,7 +359,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/type-break.el b/lisp/type-break.el index 2c928e9db1e..98947bac272 100644 --- a/lisp/type-break.el +++ b/lisp/type-break.el @@ -376,7 +376,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 @@ -563,7 +563,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 +624,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 +685,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) diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el index 4f7b5446743..67e701ecb16 100644 --- a/lisp/url/url-auth.el +++ b/lisp/url/url-auth.el @@ -194,7 +194,7 @@ key cache `url-digest-auth-storage'." (base64-encode-string (apply 'format "%016x%04x%04x%05x%05x" (random) (current-time)) 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. diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el index 632a34cdd9d..309c96cbccf 100644 --- a/lisp/url/url-cache.el +++ b/lisp/url/url-cache.el @@ -206,7 +206,7 @@ If `url-standalone-mode' is non-nil, cached items never expire." (time-add cache-time (seconds-to-time (or expire-time url-cache-expire-time))) - (current-time)))))) + nil))))) (defun url-cache-prune-cache (&optional directory) "Remove all expired files from the cache. diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index 8b676f037c6..3adca26d76f 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@ -74,6 +74,55 @@ 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]" + (seconds-to-time + (let ((s (string-to-number (nth 4 fields)))) + (if (and (= s 0) long-session) + (seconds-to-time (+ (* 365 24 60 60) (float-time))) + 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 +139,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 +395,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 +406,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 +421,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 +432,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 +464,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-file.el b/lisp/url/url-file.el index 4fac4060237..1c7c20e7c83 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-2018 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,7 +63,7 @@ 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 @@ -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-handlers.el b/lisp/url/url-handlers.el index 1fe0af65ff2..98f9f1e3739 100644 --- a/lisp/url/url-handlers.el +++ b/lisp/url/url-handlers.el @@ -28,6 +28,7 @@ ;; (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.") @@ -41,6 +42,9 @@ (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-decode loads mm-bodies, which loads mm-util. +(declare-function mm-charset-to-coding-system "mm-util" + (charset &optional lbt allow-override silent)) ;; Implementation status ;; --------------------- @@ -183,6 +187,7 @@ the arguments that would have been passed to OPERATION." (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) @@ -228,6 +233,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"))) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index aed0efab01a..0b95453b300 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) @@ -238,6 +239,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 +284,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', using `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 +299,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 +320,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 +355,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 @@ -623,6 +651,12 @@ 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) + (`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 @@ -1258,7 +1292,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 +1328,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,7 +1347,8 @@ 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) diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el index cd30d94a72b..cfa8e9affe0 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,11 +148,14 @@ 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) diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 85bfb65cb68..ffae984941e 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -627,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 62abcffe393..ef990a75883 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") diff --git a/lisp/url/url.el b/lisp/url/url.el index 20c57115426..ea581010178 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -259,8 +259,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)) + (< (float-time (time-subtract nil start-time)) timeout))) (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)" diff --git a/lisp/userlock.el b/lisp/userlock.el index 5ba971ba6c8..73bb0d2aae0 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 diff --git a/lisp/vc/add-log.el b/lisp/vc/add-log.el index cbfd10affd1..4d69aac454c 100644 --- a/lisp/vc/add-log.el +++ b/lisp/vc/add-log.el @@ -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))))) @@ -1019,6 +1024,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 +1079,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 +1106,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/diff-mode.el b/lisp/vc/diff-mode.el index 7db5ca9b259..1e2fbb97fcf 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -891,7 +891,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)) @@ -1387,12 +1387,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 +1400,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,7 +1415,7 @@ 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) @@ -1433,10 +1433,10 @@ the mode if ARG is omitted or nil. ;; 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1468,7 +1468,7 @@ modified lines of the diff." (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." @@ -1693,7 +1693,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)))) @@ -1874,11 +1874,13 @@ then `diff-jump-to-old-file' is also set, for the next invocations." ;; 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))) + (rev (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) (pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched) (diff-find-source-location other-file rev))) (pop-to-buffer buf) (goto-char (+ (car pos) (cdr src))) + (when buffer (next-error-found buffer (current-buffer))) (diff-hunk-status-msg line-offset (diff-xor rev switched) t)))) @@ -2047,7 +2049,7 @@ Return new point, if it was moved." (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))))) + nil #'diff-refine-preproc props-r props-a))))) (`context (let* ((middle (save-excursion (re-search-forward "^---"))) (other middle)) @@ -2060,7 +2062,7 @@ Return new point, if it was moved." (match-beginning 0)) other (if diff-use-changed-face props-c) - 'diff-refine-preproc + #'diff-refine-preproc (unless diff-use-changed-face props-r) (unless diff-use-changed-face props-a))))) (_ ;; Normal diffs. @@ -2069,7 +2071,7 @@ Return new point, if it was moved." ;; 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))))))))) + nil #'diff-refine-preproc props-r props-a))))))))) (defun diff-undo (&optional arg) "Perform `undo', ignoring the buffer's read-only status." @@ -2175,6 +2177,54 @@ fixed, visit it in a buffer." modified-buffers ", ")) (message "No trailing whitespace to delete."))))) +;;; 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) (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/ediff-merg.el b/lisp/vc/ediff-merg.el index ad72d7570c5..b67f520ca07 100644 --- a/lisp/vc/ediff-merg.el +++ b/lisp/vc/ediff-merg.el @@ -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 diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el index 8670ba4603f..104a5782682 100644 --- a/lisp/vc/ediff-util.el +++ b/lisp/vc/ediff-util.el @@ -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 @@ -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) diff --git a/lisp/vc/ediff-wind.el b/lisp/vc/ediff-wind.el index 079e195291d..0535aa67253 100644 --- a/lisp/vc/ediff-wind.el +++ b/lisp/vc/ediff-wind.el @@ -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 @@ -132,7 +128,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'. @@ -145,7 +141,7 @@ In this case, Ediff will use those frames to display these buffers." function) :group 'ediff-window) -(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'. @@ -212,7 +208,7 @@ responsibility." :type 'boolean :group 'ediff-window) -(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 @@ -260,7 +256,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 @@ -336,11 +332,11 @@ 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)) @@ -354,7 +350,7 @@ into icons, regardless of the window manager." ;; 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 +364,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 +415,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 +434,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 +460,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 +485,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,23 +504,23 @@ 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. @@ -534,7 +530,7 @@ into icons, regardless of the window manager." (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 +539,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 +564,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 +722,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 +736,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 +755,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 +783,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 +793,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 +806,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 +823,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 +892,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 +954,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 +981,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 +1080,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 +1105,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 +1359,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 cd2b2c4e628..32a6820fe7d 100644 --- a/lisp/vc/ediff.el +++ b/lisp/vc/ediff.el @@ -112,10 +112,6 @@ (provide 'ediff) -;; Compiler pacifier -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r)))) - (require 'ediff-util) ;; end pacifier @@ -153,7 +149,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 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 438ef117da6..6ff782a6061 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -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 ;;; @@ -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) diff --git a/lisp/vc/pcvs-info.el b/lisp/vc/pcvs-info.el index 7e727670554..edcfc6e6c4c 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." diff --git a/lisp/vc/pcvs-parse.el b/lisp/vc/pcvs-parse.el index 8db2fe5e836..dbd25d93a1e 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.el b/lisp/vc/pcvs.el index 5515e0cd608..501666a4997 100644 --- a/lisp/vc/pcvs.el +++ b/lisp/vc/pcvs.el @@ -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)) diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index ea99d31e898..99a074cf258 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -104,7 +104,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 +112,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 diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 0cd05b943ec..18da6e33578 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -554,11 +554,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 diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index b0d2221b255..da9d34644cd 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -290,16 +290,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 +324,7 @@ 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)) + (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,11 @@ 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)) + (message "Done in background: %s" full-command))))) ;; Run synchronously (when vc-command-messages - (message "Running %s in foreground..." full-command)) + (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 +346,14 @@ 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)))) + (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-git.el b/lisp/vc/vc-git.el index efe853e5eeb..88052d7749b 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -102,8 +102,7 @@ (eval-when-compile (require 'cl-lib) (require 'vc) - (require 'vc-dir) - (require 'grep)) + (require 'vc-dir)) (defgroup vc-git nil "VC Git backend." @@ -183,6 +182,10 @@ Should be consistent with the Git config value i18n.logOutputEncoding." ;; 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) @@ -860,13 +863,15 @@ It is based on `log-edit-mode', and has Git-specific extensions.") (vc-git-command nil nil file "checkout" "-q" "--"))) (defvar vc-git-error-regexp-alist - '(("^ \\(.+\\) |" 1 nil nil 0)) + '(("^ \\(.+\\)\\> *|" 1 nil nil 0)) "Value of `compilation-error-regexp-alist' in *vc-git* buffers.") ;; 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) +(defun vc-git--pushpull (command prompt extra-args) "Run COMMAND (a string; either push or pull) on the current Git branch. If PROMPT is non-nil, prompt for the Git command to run." (let* ((root (vc-git-root default-directory)) @@ -885,6 +890,7 @@ If PROMPT is non-nil, prompt for the Git command to run." (setq git-program (car args) command (cadr args) args (cddr args))) + (setq args (nconc args extra-args)) (require 'vc-dispatcher) (apply 'vc-do-async-command buffer root git-program command args) (with-current-buffer buffer @@ -892,7 +898,7 @@ If PROMPT is non-nil, prompt for the Git command to run." (vc-compilation-mode 'git) (setq-local compile-command (concat git-program " " command " " - (if args (mapconcat 'identity args " ") ""))) + (mapconcat 'identity args " "))) (setq-local compilation-directory root) ;; Either set `compilation-buffer-name-function' locally to nil ;; or use `compilation-arguments' to set `name-function'. @@ -907,13 +913,13 @@ If PROMPT is non-nil, prompt for the Git command to run." "Pull changes into the current Git branch. Normally, this runs \"git pull\". If PROMPT is non-nil, prompt for the Git command to run." - (vc-git--pushpull "pull" prompt)) + (vc-git--pushpull "pull" prompt '("--stat"))) (defun vc-git-push (prompt) "Push changes from the current Git branch. Normally, this runs \"git push\". If PROMPT is non-nil, prompt for the Git command to run." - (vc-git--pushpull "push" prompt)) + (vc-git--pushpull "push" prompt nil)) (defun vc-git-merge-branch () "Merge changes into the current Git branch. @@ -1382,6 +1388,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")) @@ -1406,6 +1415,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) @@ -1474,9 +1484,24 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (vc-git--call nil "stash" "save" name) (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*") @@ -1486,16 +1511,22 @@ 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) @@ -1564,7 +1595,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)) diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 2deac2aae27..14df9d8b673 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 @@ -175,6 +175,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) @@ -1012,8 +1016,8 @@ hg binary." (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) + ;; We want to store 32-bit unsigned values in fixnums. + (zerop (lsh -1 32)) (progn (setf repo-relative-filename (file-relative-name truename repo)) @@ -1296,12 +1300,8 @@ REV is the revision to check out into WORKFILE." (vc-hg-command buffer 1 nil "outgoing" "-n" (unless (string= remote-location "") remote-location))) -(defvar vc-hg-error-regexp-alist nil - ;; 'hg pull' does not list modified files, so, for now, the only - ;; benefit of `vc-compilation-mode' is that one can get rid of - ;; *vc-hg* buffer with 'q' or 'z'. - ;; TODO: call 'hg incoming' before pull/merge to get the list of - ;; modified files +(defvar vc-hg-error-regexp-alist + '(("^M \\(.+\\)" 1 nil nil 0)) "Value of `compilation-error-regexp-alist' in *vc-hg* buffers.") (autoload 'vc-do-async-command "vc-dispatcher") @@ -1309,9 +1309,10 @@ REV is the revision to check out into WORKFILE." (defvar compilation-directory) (defvar compilation-arguments) ; defined in compile.el -(defun vc-hg--pushpull (command prompt &optional obsolete) +(defun vc-hg--pushpull (command prompt post-processing &optional obsolete) "Run COMMAND (a string; either push or pull) on the current Hg branch. If PROMPT is non-nil, prompt for the Hg command to run. +POST-PROCESSING is a list of commands to execute after the command. If OBSOLETE is non-nil, behave like the old versions of the Hg push/pull commands, which only operated on marked files." (let (marked-list) @@ -1327,18 +1328,14 @@ commands, which only operated on marked files." (let* ((root (vc-hg-root default-directory)) (buffer (format "*vc-hg : %s*" (expand-file-name root))) (hg-program vc-hg-program) - ;; Fixme: before updating the working copy to the latest - ;; state, should check if it's visiting an old revision. - (args (if (equal command "pull") '("-u")))) + args) ;; If necessary, prompt for the exact command. ;; TODO if pushing, prompt if no default push location - cf bzr. (when prompt (setq args (split-string (read-shell-command (format "Hg %s command: " command) - (format "%s %s%s" hg-program command - (if (not args) "" - (concat " " (mapconcat 'identity args " ")))) + (format "%s %s" hg-program command) 'vc-hg-history) " " t)) (setq hg-program (car args) @@ -1347,10 +1344,17 @@ commands, which only operated on marked files." (apply 'vc-do-async-command buffer root hg-program command args) (with-current-buffer buffer (vc-run-delayed + (dolist (cmd post-processing) + (apply 'vc-do-command buffer nil hg-program nil cmd)) (vc-compilation-mode 'hg) (setq-local compile-command (concat hg-program " " command " " - (if args (mapconcat 'identity args " ") ""))) + (mapconcat 'identity args " ") + (mapconcat (lambda (args) + (concat " && " hg-program " " + (mapconcat 'identity + args " "))) + post-processing ""))) (setq-local compilation-directory root) ;; Either set `compilation-buffer-name-function' locally to nil ;; or use `compilation-arguments' to set `name-function'. @@ -1371,7 +1375,15 @@ specific Mercurial pull command. The default is \"hg pull -u\", which fetches changesets from the default remote repository and then attempts to update the working directory." (interactive "P") - (vc-hg--pushpull "pull" prompt (called-interactively-p 'interactive))) + (vc-hg--pushpull "pull" prompt + ;; Fixme: before updating the working copy to the latest + ;; state, should check if it's visiting an old revision. + ;; post-processing: list modified files and update + ;; NB: this will not work with "pull = --rebase" + ;; or "pull = --update" in hgrc. + '(("--pager" "no" "status" "--rev" "." "--rev" "tip") + ("update")) + (called-interactively-p 'interactive))) (defun vc-hg-push (prompt) "Push changes from the current Mercurial branch. @@ -1381,7 +1393,7 @@ for the Hg command to run. If called interactively with a set of marked Log View buffers, call \"hg push -r REVS\" to push the specified revisions REVS." (interactive "P") - (vc-hg--pushpull "push" prompt (called-interactively-p 'interactive))) + (vc-hg--pushpull "push" prompt nil (called-interactively-p 'interactive))) (defun vc-hg-merge-branch () "Merge incoming changes into the current working directory. diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 93e9c25cbfd..cceca717953 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -729,13 +729,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]." @@ -1649,11 +1642,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. @@ -2420,11 +2408,13 @@ When called interactively with a prefix argument, prompt for REMOTE-LOCATION." 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) diff --git a/lisp/version.el b/lisp/version.el index 3a38b1d83c8..84919308191 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") diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el index 9b9d3ce9adc..825420c4261 100644 --- a/lisp/w32-fns.el +++ b/lisp/w32-fns.el @@ -31,13 +31,13 @@ ;;;; 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)) (defun w32-shell-name () "Return the name of the shell being used." @@ -126,22 +126,16 @@ You should set this to t when using a non-system shell.\n\n")))) ;; (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) @@ -242,7 +236,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 +254,48 @@ 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 "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)) ;;;; Support for build process diff --git a/lisp/w32-vars.el b/lisp/w32-vars.el index 3531b94f15f..44f9b7670db 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/whitespace.el b/lisp/whitespace.el index e78962201b2..c2827d3d518 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2000-2018 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> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: data, wp ;; Version: 13.2.2 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre diff --git a/lisp/windmove.el b/lisp/windmove.el index db77d810e05..f5650684097 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -543,16 +543,18 @@ 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 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 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)) (provide 'windmove) diff --git a/lisp/window.el b/lisp/window.el index abd1a68b1f0..085e51646f8 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -6641,6 +6641,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 @@ -6654,7 +6655,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. @@ -7289,12 +7289,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. @@ -7360,6 +7371,17 @@ below the selected one, use that window." (window--display-buffer buffer window 'reuse alist display-buffer-mark-dedicated))))) +(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)))) + (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 @@ -7376,8 +7398,8 @@ 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)) @@ -8901,35 +8923,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. @@ -8937,15 +8941,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.") diff --git a/lisp/woman.el b/lisp/woman.el index 533f14674ab..238a7d389c4 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)) @@ -2071,14 +2071,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 @@ -3663,46 +3663,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 fe2202cfc68..5f8578444a0 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. diff --git a/lisp/xdg.el b/lisp/xdg.el index 96c43dea172..a896eb855a8 100644 --- a/lisp/xdg.el +++ b/lisp/xdg.el @@ -34,6 +34,7 @@ ;;; Code: (eval-when-compile + (require 'cl-lib) (require 'subr-x)) @@ -212,6 +213,108 @@ 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 (nth 5 (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 3bc8c08cb7b..6ce944ccb82 100644 --- a/lisp/xml.el +++ b/lisp/xml.el @@ -1073,6 +1073,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 |