diff options
Diffstat (limited to 'lisp')
346 files changed, 11183 insertions, 7965 deletions
diff --git a/lisp/abbrev.el b/lisp/abbrev.el index 734cefbb7be..197276cc9ce 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -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 77aa906ee6c..a0456d5bd26 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -1687,7 +1687,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..ce3ec09e286 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) @@ -1064,7 +1063,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 +2044,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..3e6a9cccbc4 100644 --- a/lisp/auth-source-pass.el +++ b/lisp/auth-source-pass.el @@ -139,11 +139,6 @@ 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))) @@ -159,6 +154,11 @@ CONTENTS is the contents of a password-store formatted file." (hostname hostname) (t host)))) +(defun auth-source-pass--user (host) + "Extract user from HOST and return it. +Return nil if no match was found." + (url-user (url-generic-parse-url host))) + (defun auth-source-pass--do-debug (&rest msg) "Call `auth-source-do-debug` with MSG and a prefix." (apply #'auth-source-do-debug @@ -235,14 +235,17 @@ matching USER." If many matches are found, return the first one. If no match is found, return nil." (or - (if (url-user (url-generic-parse-url host)) + (if (auth-source-pass--user 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 + ;; if that didn't work, search for HOST without its user component, if any (auth-source-pass--find-one-by-entry-name (auth-source-pass--hostname host) user) + ;; if that didn't work, search for HOST with user extracted from it + (auth-source-pass--find-one-by-entry-name + (auth-source-pass--hostname host) (auth-source-pass--user host)) ;; if that didn't work, remove subdomain: foo.bar.com -> bar.com (let ((components (split-string host "\\."))) (when (= (length components) 3) diff --git a/lisp/auth-source.el b/lisp/auth-source.el index c605c112a51..66e1897b877 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)) @@ -379,24 +380,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) @@ -1299,9 +1315,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 @@ -1967,6 +1981,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 e03b9e9a0cb..6ef8ffb0933 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/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 dae7b9dc005..4bf8b67ee53 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. @@ -115,6 +115,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) @@ -372,7 +403,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: @@ -466,8 +497,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") @@ -477,7 +508,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 @@ -486,7 +517,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 @@ -506,7 +537,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 @@ -519,7 +550,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 @@ -543,8 +574,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. @@ -715,7 +746,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) @@ -940,7 +971,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'. @@ -1105,7 +1136,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)) @@ -1357,7 +1388,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))) @@ -1459,8 +1490,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. @@ -1475,7 +1507,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. @@ -1495,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." @@ -1755,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)) @@ -1790,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 () @@ -2032,11 +2064,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"] @@ -2254,7 +2286,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))) @@ -2276,13 +2308,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 @@ -2322,7 +2347,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." @@ -2425,7 +2450,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) @@ -2497,13 +2522,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. @@ -2606,11 +2632,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..ca3adfaeeb5 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -1048,12 +1048,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 +1071,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 +1094,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 +1201,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 +1221,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 +1254,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 +1763,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 +1975,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 +2011,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) @@ -2066,12 +2066,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 +2164,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 +2174,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 +2199,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 +2217,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 +2467,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 +2476,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 +2496,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 +2511,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/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/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/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..7c9f102951d 100644 --- a/lisp/cedet/semantic/analyze.el +++ b/lisp/cedet/semantic/analyze.el @@ -440,12 +440,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 +463,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)) ) ))) @@ -723,12 +720,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/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/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/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/texi.el b/lisp/cedet/semantic/texi.el index 9769ae89289..7fe19324793 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." diff --git a/lisp/cedet/srecode/dictionary.el b/lisp/cedet/srecode/dictionary.el index 4a84693fe7e..f1287f68022 100644 --- a/lisp/cedet/srecode/dictionary.el +++ b/lisp/cedet/srecode/dictionary.el @@ -612,10 +612,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/map.el b/lisp/cedet/srecode/map.el index 7c9424945f0..f885b49614d 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 "*"))) 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 9e5e7c69d97..3163afeff40 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -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) @@ -1434,24 +1434,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 +1480,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." @@ -2279,8 +2289,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/cus-edit.el b/lisp/cus-edit.el index 3ede483dade..816c7f7881a 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 diff --git a/lisp/cus-start.el b/lisp/cus-start.el index dace6f79549..9ba1e105a1b 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -413,6 +413,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) @@ -429,13 +433,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) @@ -705,13 +709,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/desktop.el b/lisp/desktop.el index b98319bdcf5..8bd44658d85 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -1564,8 +1564,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) diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index c336103f80b..e8b5e6755ea 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))) @@ -2747,7 +2767,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 +2782,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 +2800,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 +2828,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 +2852,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..fa36083e14e 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -1335,7 +1335,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..1c283c5de3f 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 @@ -2343,12 +2352,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 +2999,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 +3028,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 +3096,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/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..7b4a7d04f92 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))))))) diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index d74446c7479..b86b56b81ec 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) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c90509d131b..a316364761d 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1281,7 +1281,10 @@ ;; errors to compile time. (let ((pure-fns - '(concat symbol-name regexp-opt regexp-quote string-to-syntax))) + '(concat symbol-name regexp-opt regexp-quote string-to-syntax + string-to-char + ash lsh logb lognot logior logxor + ceiling floor))) (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 c179ffcafd6..1bf6d04b63b 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1938,17 +1938,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 +2069,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!" @@ -2508,6 +2492,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) @@ -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))))) 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..59b7831fb58 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.") +(eval-when-compile (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 e7f82ced488..4d4640cbe0d 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))) @@ -882,7 +892,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 @@ -951,7 +961,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: ;; @@ -986,7 +996,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 @@ -1307,11 +1334,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)) @@ -1326,6 +1355,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) @@ -1336,16 +1366,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) @@ -1490,10 +1523,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--"))) @@ -2055,23 +2089,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. @@ -2080,7 +2106,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))) @@ -2088,60 +2114,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)) @@ -2153,16 +2221,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 @@ -2174,7 +2244,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. @@ -2425,10 +2496,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)) @@ -2455,7 +2527,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))) @@ -2645,6 +2719,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 de41d826713..78cd6f9d9e5 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -269,12 +269,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/debug.el b/lisp/emacs-lisp/debug.el index 593fab97275..4624da30267 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -273,6 +273,12 @@ first will be printed into the backtrace buffer." (setq debug-on-next-call debugger-step-after-exit) 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 +293,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 +342,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 +367,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 +377,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 +423,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 +538,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 +560,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..547f5cd805b 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -281,12 +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))))))) + ,@(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))))) ;; PUBLIC: find the ultimate class of a derived mode. 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..4f97712b980 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))) diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index f0fed17b7da..c0ad7ac4605 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -487,7 +487,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 78275acd9c2..1e1419f6eb7 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -377,9 +377,21 @@ is a shorthand for (NAME NAME)." (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..eae0dacfd23 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) 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..a47108545d1 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1333,6 +1333,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,10 +1352,11 @@ 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)" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats)))))) (run-ended (cl-destructuring-bind (stats abortedp) event-args (let ((unexpected (ert-stats-completed-unexpected stats)) @@ -1438,16 +1442,17 @@ 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"))) + (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)))))))) nil)) ;;;###autoload @@ -2544,8 +2549,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 +2585,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 +2599,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 +2618,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..300bfab3233 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. diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index e210def1a0f..01634d84ca5 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -303,11 +303,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/package.el b/lisp/emacs-lisp/package.el index c56502236ee..999e0d07524 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: @@ -961,17 +961,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,16 +1431,11 @@ 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. @@ -1454,13 +1444,7 @@ individual packages after calling `package-initialize' -- this is taken care of by `package-initialize'." (interactive) (setq package-alist nil) - (if after-init-time - (package--ensure-init-file) - ;; If `package-initialize' is before we finished loading the init - ;; file, it's obvious we don't need to ensure-init. - (setq package--init-file-ensured t - ;; And likely we don't need to run it again after init. - package-enable-at-startup nil)) + (setq package-enable-at-startup nil) (package-load-all-descriptors) (package-read-all-archive-contents) (unless no-activate @@ -1877,64 +1861,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. 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/testcover.el b/lisp/emacs-lisp/testcover.el index dff990ea401..613f69c4f62 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: @@ -89,16 +90,14 @@ these. This list is quite incomplete!" buffer-disable-undo buffer-enable-undo current-global-map deactivate-mark delete-backward-char delete-char delete-region ding forward-char function* insert insert-and-inherit kill-all-local-variables - kill-line kill-paragraph kill-region kill-sexp lambda + kill-line kill-paragraph kill-region kill-sexp minibuffer-complete-and-exit narrow-to-region next-line push-mark put-text-property run-hooks set-match-data signal substitute-key-definition suppress-keymap undo use-local-map while widen yank) - "Functions that always return the same value. No brown splotch is shown -for these. This list is quite incomplete! Notes: Nobody ever changes the -current global map. The macro `lambda' is self-evaluating, hence always -returns the same value (the function it defines may return varying values -when called)." + "Functions that always return the same value, according to `equal'. +No brown splotch is shown for these. This list is quite +incomplete! Notes: Nobody ever changes the current global map." :group 'testcover :type '(repeat symbol)) @@ -111,7 +110,7 @@ them as having returned nil just before calling them." (defcustom testcover-compose-functions '(+ - * / = append length list make-keymap make-sparse-keymap - mapcar message propertize replace-regexp-in-string + message propertize replace-regexp-in-string run-with-idle-timer set-buffer-modified-p) "Functions that are 1-valued if all their args are either constants or calls to one of the `testcover-1value-functions', so if that's true then no @@ -186,19 +185,18 @@ call to one of the `testcover-1value-functions'." ;;;###autoload (defun testcover-start (filename &optional byte-compile) - "Uses edebug to instrument all macros and functions in FILENAME, then -changes the instrumentation from edebug to testcover--much faster, no -problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is -non-nil, byte-compiles each function after instrumenting." + "Use Edebug to instrument for coverage all macros and functions in FILENAME. +If BYTE-COMPILE is non-nil, byte compile each function after instrumenting." (interactive "fStart covering file: ") - (let ((buf (find-file filename)) - (load-read-function load-read-function)) - (add-function :around load-read-function - #'testcover--read) - (setq edebug-form-data nil - testcover-module-constants nil - testcover-module-1value-functions nil) - (eval-buffer buf)) + (let ((buf (find-file filename))) + (setq edebug-form-data nil + testcover-module-constants nil + testcover-module-1value-functions nil + testcover-module-potentially-1value-functions nil) + (let ((edebug-all-defs t) + (edebug-after-instrumentation-function #'testcover-after-instrumentation) + (edebug-new-definition-function #'testcover-init-definition)) + (eval-buffer buf))) (when byte-compile (dolist (x (reverse edebug-form-data)) (when (fboundp (car x)) @@ -209,229 +207,10 @@ non-nil, byte-compiles each function after instrumenting." (defun testcover-this-defun () "Start coverage on function under point." (interactive) - (let ((x (let ((edebug-all-defs t)) - (symbol-function (eval-defun nil))))) - (testcover-reinstrument x) - x)) - -(defun testcover--read (orig &optional stream) - "Read a form using edebug, changing edebug callbacks to testcover callbacks." - (or stream (setq stream standard-input)) - (if (eq stream (current-buffer)) - (let ((x (let ((edebug-all-defs t)) - (edebug-read-and-maybe-wrap-form)))) - (testcover-reinstrument x) - x) - (funcall (or orig #'read) stream))) - -(defun testcover-reinstrument (form) - "Reinstruments FORM to use testcover instead of edebug. This -function modifies the list that FORM points to. Result is nil if -FORM should return multiple values, t if should always return same -value, `maybe' if either is acceptable." - (let ((fun (car-safe form)) - id val) - (cond - ((not fun) ;Atom - (when (or (not (symbolp form)) - (memq form testcover-constants) - (memq form testcover-module-constants)) - t)) - ((consp fun) ;Embedded list - (testcover-reinstrument fun) - (testcover-reinstrument-list (cdr form)) - nil) - ((or (memq fun testcover-1value-functions) - (memq fun testcover-module-1value-functions)) - ;;Should always return same value - (testcover-reinstrument-list (cdr form)) - t) - ((or (memq fun testcover-potentially-1value-functions) - (memq fun testcover-module-potentially-1value-functions)) - ;;Might always return same value - (testcover-reinstrument-list (cdr form)) - 'maybe) - ((memq fun testcover-progn-functions) - ;;1-valued if last argument is - (testcover-reinstrument-list (cdr form))) - ((memq fun testcover-prog1-functions) - ;;1-valued if first argument is - (testcover-reinstrument-list (cddr form)) - (testcover-reinstrument (cadr form))) - ((memq fun testcover-compose-functions) - ;;1-valued if all arguments are. Potentially 1-valued if all - ;;arguments are either definitely or potentially. - (testcover-reinstrument-compose (cdr form) 'testcover-reinstrument)) - ((eq fun 'edebug-enter) - ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS)) - ;; => (testcover-enter 'SYM #'(lambda nil FORMS)) - (setcar form 'testcover-enter) - (setcdr (nthcdr 1 form) (nthcdr 3 form)) - (let ((testcover-vector (get (cadr (cadr form)) 'edebug-coverage))) - (testcover-reinstrument-list (nthcdr 2 (cadr (nth 2 form)))))) - ((eq fun 'edebug-after) - ;;(edebug-after (edebug-before XXX) YYY FORM) - ;; => (testcover-after YYY FORM), mark XXX as ok-coverage - (unless (eq (cadr form) 0) - (aset testcover-vector (cadr (cadr form)) 'ok-coverage)) - (setq id (nth 2 form)) - (setcdr form (nthcdr 2 form)) - (setq val (testcover-reinstrument (nth 2 form))) - (setcar form (if (eq val t) - 'testcover-1value - 'testcover-after)) - (when val - ;;1-valued or potentially 1-valued - (aset testcover-vector id '1value)) - (cond - ((memq (car-safe (nth 2 form)) testcover-noreturn-functions) - ;;This function won't return, so set the value in advance - ;;(edebug-after (edebug-before XXX) YYY FORM) - ;; => (progn (edebug-after YYY nil) FORM) - (setcar (cdr form) `(,(car form) ,id nil)) - (setcar form 'progn) - (aset testcover-vector id '1value) - (setq val t)) - ((eq (car-safe (nth 2 form)) '1value) - ;;This function is always supposed to return the same value - (setq val t) - (aset testcover-vector id '1value) - (setcar form 'testcover-1value))) - val) - ((eq fun 'defun) - (setq val (testcover-reinstrument-list (nthcdr 3 form))) - (when (eq val t) - (push (cadr form) testcover-module-1value-functions)) - (when (eq val 'maybe) - (push (cadr form) testcover-module-potentially-1value-functions))) - ((memq fun '(defconst defcustom)) - ;;Define this symbol as 1-valued - (push (cadr form) testcover-module-constants) - (testcover-reinstrument-list (cddr form))) - ((memq fun '(dotimes dolist)) - ;;Always returns third value from SPEC - (testcover-reinstrument-list (cddr form)) - (setq val (testcover-reinstrument-list (cadr form))) - (if (nth 2 (cadr form)) - val - ;;No third value, always returns nil - t)) - ((memq fun '(let let*)) - ;;Special parsing for second argument - (mapc 'testcover-reinstrument-list (cadr form)) - (testcover-reinstrument-list (cddr form))) - ((eq fun 'if) - ;;Potentially 1-valued if both THEN and ELSE clauses are - (testcover-reinstrument (cadr form)) - (let ((then (testcover-reinstrument (nth 2 form))) - (else (testcover-reinstrument-list (nthcdr 3 form)))) - (and then else 'maybe))) - ((eq fun 'cond) - ;;Potentially 1-valued if all clauses are - (when (testcover-reinstrument-compose (cdr form) - 'testcover-reinstrument-list) - 'maybe)) - ((eq fun 'condition-case) - ;;Potentially 1-valued if BODYFORM is and all HANDLERS are - (let ((body (testcover-reinstrument (nth 2 form))) - (errs (testcover-reinstrument-compose - (mapcar #'cdr (nthcdr 3 form)) - 'testcover-reinstrument-list))) - (and body errs 'maybe))) - ((eq fun 'quote) - ;;Don't reinstrument what's inside! - ;;This doesn't apply within a backquote - t) - ((eq fun '\`) - ;;Quotes are not special within backquotes - (let ((testcover-1value-functions - (cons 'quote testcover-1value-functions))) - (testcover-reinstrument (cadr form)))) - ((eq fun '\,) - ;;In commas inside backquotes, quotes are special again - (let ((testcover-1value-functions - (remq 'quote testcover-1value-functions))) - (testcover-reinstrument (cadr form)))) - ((eq fun '1value) - ;;Hack - pretend the arg is 1-valued here - (cond - ((symbolp (cadr form)) - ;;A pseudoconstant variable - t) - ((and (eq (car (cadr form)) 'edebug-after) - (symbolp (nth 3 (cadr form)))) - ;;Reference to pseudoconstant - (aset testcover-vector (nth 2 (cadr form)) '1value) - (setcar (cdr form) `(testcover-1value ,(nth 2 (cadr form)) - ,(nth 3 (cadr form)))) - t) - (t - (setq id (car (if (eq (car (cadr form)) 'edebug-after) - (nth 3 (cadr form)) - (cadr form)))) - (let ((testcover-1value-functions - (cons id testcover-1value-functions))) - (testcover-reinstrument (cadr form)))))) - ((eq fun 'noreturn) - ;;Hack - pretend the arg has no return - (cond - ((symbolp (cadr form)) - ;;A pseudoconstant variable - 'maybe) - ((and (eq (car (cadr form)) 'edebug-after) - (symbolp (nth 3 (cadr form)))) - ;;Reference to pseudoconstant - (aset testcover-vector (nth 2 (cadr form)) '1value) - (setcar (cdr form) `(progn (testcover-after ,(nth 2 (cadr form)) nil) - ,(nth 3 (cadr form)))) - 'maybe) - (t - (setq id (car (if (eq (car (cadr form)) 'edebug-after) - (nth 3 (cadr form)) - (cadr form)))) - (let ((testcover-noreturn-functions - (cons id testcover-noreturn-functions))) - (testcover-reinstrument (cadr form)))))) - ((and (eq fun 'apply) - (eq (car-safe (cadr form)) 'quote) - (symbolp (cadr (cadr form)))) - ;;Apply of a constant symbol. Process as 1value or noreturn - ;;depending on symbol. - (setq fun (cons (cadr (cadr form)) (cddr form)) - val (testcover-reinstrument fun)) - (setcdr (cdr form) (cdr fun)) - val) - (t ;Some other function or weird thing - (testcover-reinstrument-list (cdr form)) - nil)))) - -(defun testcover-reinstrument-list (list) - "Reinstruments each form in LIST to use testcover instead of edebug. -This function modifies the forms in LIST. Result is `testcover-reinstrument's -value for the last form in LIST. If the LIST is empty, its evaluation will -always be nil, so we return t for 1-valued." - (let ((result t)) - (while (consp list) - (setq result (testcover-reinstrument (pop list)))) - result)) - -(defun testcover-reinstrument-compose (list fun) - "For a compositional function, the result is 1-valued if all -arguments are, potentially 1-valued if all arguments are either -definitely or potentially 1-valued, and multi-valued otherwise. -FUN should be `testcover-reinstrument' for compositional functions, - `testcover-reinstrument-list' for clauses in a `cond'." - (let ((result t)) - (mapc #'(lambda (x) - (setq x (funcall fun x)) - (cond - ((eq result t) - (setq result x)) - ((eq result 'maybe) - (when (not x) - (setq result nil))))) - list) - result)) + (let ((edebug-all-defs t) + (edebug-after-instrumentation-function #'testcover-after-instrumentation) + (edebug-new-definition-function #'testcover-init-definition)) + (eval-defun nil))) (defun testcover-end (filename) "Turn off instrumentation of all macros and functions in FILENAME." @@ -444,48 +223,108 @@ FUN should be `testcover-reinstrument' for compositional functions, ;;; Accumulate coverage data ;;;========================================================================= -(defun testcover-enter (testcover-sym testcover-fun) - "Internal function for coverage testing. Invokes TESTCOVER-FUN while -binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM -\(the name of the current function)." - (let ((testcover-vector (get testcover-sym 'edebug-coverage))) - (funcall testcover-fun))) - -(defun testcover-after (idx val) - "Internal function for coverage testing. Returns VAL after installing it in -`testcover-vector' at offset IDX." - (declare (gv-expander (lambda (do) - (gv-letplace (getter setter) val - (funcall do getter - (lambda (store) - `(progn (testcover-after ,idx ,getter) - ,(funcall setter store)))))))) - (cond - ((eq (aref testcover-vector idx) 'unknown) - (aset testcover-vector idx val)) - ((not (condition-case () - (equal (aref testcover-vector idx) val) - ;; TODO: Actually check circular lists for equality. - (circular-list nil))) - (aset testcover-vector idx 'ok-coverage))) - val) - -(defun testcover-1value (idx val) - "Internal function for coverage testing. Returns VAL after installing it in -`testcover-vector' at offset IDX. Error if FORM does not always return the -same value during coverage testing." - (cond - ((eq (aref testcover-vector idx) '1value) - (aset testcover-vector idx (cons '1value val))) - ((not (and (eq (car-safe (aref testcover-vector idx)) '1value) - (condition-case () - (equal (cdr (aref testcover-vector idx)) val) - ;; TODO: Actually check circular lists for equality. - (circular-list nil)))) - (error "Value of form marked with `1value' does vary: %s" val))) - val) - - +(defun testcover-after-instrumentation (form) + "Analyze FORM for code coverage." + (testcover-analyze-coverage form) + form) + +(defun testcover-init-definition (sym) + "Mark SYM as under test coverage." + (message "Testcover: %s" sym) + (put sym 'edebug-behavior 'testcover)) + +(defun testcover-enter (func _args body) + "Begin execution of a function under coverage testing. +Bind `testcover-vector' to the code-coverage vector for FUNC and +return the result of evaluating BODY." + (let ((testcover-vector (get func 'edebug-coverage))) + (funcall body))) + +(defun testcover-before (before-index) + "Update code coverage before a form is evaluated. +BEFORE-INDEX is the form's index into the code-coverage vector." + (let ((before-entry (aref testcover-vector before-index))) + (when (eq (car-safe before-entry) 'noreturn) + (let* ((after-index (cdr before-entry))) + (aset testcover-vector after-index '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 +356,13 @@ eliminated by adding more test cases." (while (> len 0) (setq len (1- len) data (aref coverage len)) - (when (and (not (eq data 'ok-coverage)) - (not (eq (car-safe data) '1value)) - (setq j (+ def-mark (aref points len)))) + (when (and (not (eq data '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 +393,284 @@ 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)) + (dolist (form forms) + (let ((val (funcall func form))) + (setq result (testcover-coverage-combine result val)))) + 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/thunk.el b/lisp/emacs-lisp/thunk.el index f12633e6de1..bbdd7d61f6c 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: +(eval-when-compile (require 'cl-macs)) + (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/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index fe57535a14b..224ce5802c6 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -131,9 +131,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-util.el b/lisp/emulation/viper-util.el index f0540401803..9fd68b7a61f 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -39,7 +39,6 @@ (defvar ex-unix-type-shell-options) (defvar viper-ex-tmp-buf-name) (defvar viper-syntax-preference) -(defvar viper-saved-mark) (require 'ring) @@ -886,6 +885,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/epa-mail.el b/lisp/epa-mail.el index 077666ac897..c819f6734c7 100644 --- a/lisp/epa-mail.el +++ b/lisp/epa-mail.el @@ -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)) diff --git a/lisp/epa.el b/lisp/epa.el index a84e4f2b854..5c237bca9b4 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -565,7 +565,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" 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..7eec56e363b 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -644,22 +644,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..8269e5c1634 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) @@ -545,5 +545,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..5bc8c2f38b2 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. @@ -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..3294350b6ee 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -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 @@ -456,6 +456,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..62201b0e7cf 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)) @@ -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..550800c57f2 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -67,6 +67,8 @@ ;;; Code: +(load "erc-loaddefs" nil t) + (eval-when-compile (require 'cl-lib)) (require 'font-lock) (require 'pp) @@ -399,25 +401,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 +430,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 +504,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 +1277,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 +1360,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. @@ -2549,9 +2567,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 +2634,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 diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index b56cf168a2b..a9b29aef4c0 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..9a72f781fc7 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) @@ -108,6 +109,7 @@ Uses the system sudo through TRAMP's sudo method." :show-usage :usage "[(-u | --user) USER] COMMAND Execute a COMMAND as the superuser or another USER.") + args ; suppress "unused lexical variable" warning (throw 'eshell-external (let ((user (or user "root")) (host (or (file-remote-p default-directory 'host) diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index c3448de407d..04c517f82a0 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -956,6 +956,7 @@ Summarize disk usage of each FILE, recursively for directories.") :show-usage :usage "COMMAND... Show wall-clock time elapsed during execution of COMMAND.") + args ; suppress "unused lexical variable" warning (setq eshell-time-start (float-time)) (add-hook 'eshell-post-command-hook 'eshell-show-elapsed-time nil t) ;; after setting @@ -965,7 +966,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 3af8fd7cacb..18852ce5341 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -111,6 +111,7 @@ interned variable `args' (created using a `let' form)." ;; `options' is of the form (quote OPTS). (cadr options)))) (args processed-args)) + ;; Unused lexical variable warning if body does not use `args'. ,@body-forms)) ;;; Internal Functions: diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index 59fb9b926d4..f1380852b3b 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) 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..d400e0a9be7 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) @@ -351,6 +353,7 @@ This function is explicit for adding to `eshell-parse-argument-hook'." '((?h "help" nil nil "show this usage screen") :external "env" :usage "<no arguments>") + args ; suppress "unused lexical variable" warning (dolist (setting (sort (eshell-environment-variables) 'string-lessp)) (eshell-buffered-print setting "\n")) (eshell-flush))) 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 46d4b0c3686..4b67b02c386 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -963,7 +963,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 @@ -1801,7 +1802,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. @@ -2228,8 +2233,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 () @@ -3311,7 +3315,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") @@ -4521,8 +4525,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))))) @@ -5904,7 +5908,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" @@ -6436,58 +6444,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 @@ -6937,8 +6919,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 @@ -6978,60 +6961,75 @@ 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)) - (directory-file-name - (expand-file-name - (unhandled-file-name-directory default-directory))) - default-directory)) - ;; 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. - (substitute-in-file-name identity) - ;; `add' means add "/:" to the result. - (file-truename add 0) - (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) - ;; List the arguments which are filenames. - (file-name-completion 1) - (file-name-all-completions 1) - (write-region 2 5) - (rename-file 0 1) - (copy-file 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. - '(nil 0)))) - method - ;; Copy ARGUMENTS so we can replace elements in it. - (arguments (copy-sequence arguments))) + (let* ((op-returns-file-name-list + '(expand-file-name file-name-directory file-name-as-directory + directory-file-name file-name-sans-versions + find-backup-file-name file-remote-p)) + (file-name-handler-alist + (and + (not (memq operation op-returns-file-name-list)) + file-name-handler-alist)) + (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 temporary-file-directory)) + (directory-file-name + (expand-file-name + (unhandled-file-name-directory default-directory))) + default-directory)) + ;; Get a list of the indices of the args which are file names. + (file-arg-indices + (cdr (or (assq operation + ;; 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. + (append + (mapcar 'list op-returns-file-name-list) + '(;; `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 insert-file-contents 0) + ;; `unquote-then-quote' means set buffer-file-name + ;; temporarily to unquoted filename. + (verify-visited-file-modtime unquote-then-quote) + ;; List the arguments which are filenames. + (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) + (copy-directory 0 1) + (file-in-directory-p 0 1) + (make-symbolic-link 0 1) + (add-name-to-file 0 1) + (make-auto-save-file-name buffer-file-name) + (set-visited-file-modtime buffer-file-name) + ;; These file-notify-* operations take a + ;; descriptor. + (file-notify-rm-watch . nil) + (file-notify-valid-p . nil)))) + ;; 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. + (arguments (copy-sequence arguments))) (if (symbolp (car file-arg-indices)) (setq method (pop file-arg-indices))) ;; Strip off the /: from the file names that have it. @@ -7048,6 +7046,12 @@ only these files will be asked to be saved." (pcase method (`identity (car arguments)) (`add (file-name-quote (apply operation arguments))) + (`buffer-file-name + (let ((buffer-file-name + (if (string-match "\\`/:" buffer-file-name) + (substring buffer-file-name (match-end 0)) + buffer-file-name))) + (apply operation arguments))) (`insert-file-contents (let ((visit (nth 1 arguments))) (unwind-protect 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/font-lock.el b/lisp/font-lock.el index 29d3bc58646..0ed94bd0e8b 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -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 447413b3256..0cf502d5066 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -2322,7 +2322,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'. @@ -2384,12 +2383,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 +2402,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 +2429,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/generic-x.el b/lisp/generic-x.el index ea2a100a586..3e3ddc5ceb9 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -1610,7 +1610,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 +1619,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/gnus-agent.el b/lisp/gnus/gnus-agent.el index b2de1196439..ada148d20b2 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -1108,7 +1108,7 @@ downloadable." gnus-newsgroup-cached) (setq articles (gnus-sorted-ndifference (gnus-sorted-ndifference - (gnus-copy-sequence articles) + (copy-tree articles) gnus-newsgroup-downloadable) gnus-newsgroup-cached))) @@ -1123,7 +1123,7 @@ downloadable." (when gnus-newsgroup-processable (setq gnus-newsgroup-downloadable (let* ((dl gnus-newsgroup-downloadable) - (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<)) + (processable (sort (copy-tree gnus-newsgroup-processable) '<)) (gnus-newsgroup-downloadable processable)) (gnus-agent-summary-fetch-group) @@ -1513,7 +1513,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)) @@ -2833,7 +2833,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 +3089,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)) @@ -3824,7 +3824,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. diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 79b2ade62b2..f23b910ed2c 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -761,9 +761,6 @@ Obsolete; use the face `gnus-signature' for customizations instead." "Face used for highlighting a signature in the article buffer." :group 'gnus-article-highlight :group 'gnus-article-signature) -;; backward-compatibility alias -(put 'gnus-signature-face 'face-alias 'gnus-signature) -(put 'gnus-signature-face 'obsolete-face "22.1") (defface gnus-header-from '((((class color) @@ -777,9 +774,6 @@ Obsolete; use the face `gnus-signature' for customizations instead." "Face used for displaying from headers." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-from-face 'face-alias 'gnus-header-from) -(put 'gnus-header-from-face 'obsolete-face "22.1") (defface gnus-header-subject '((((class color) @@ -793,9 +787,6 @@ Obsolete; use the face `gnus-signature' for customizations instead." "Face used for displaying subject headers." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-subject-face 'face-alias 'gnus-header-subject) -(put 'gnus-header-subject-face 'obsolete-face "22.1") (defface gnus-header-newsgroups '((((class color) @@ -811,9 +802,6 @@ In the default setup this face is only used for crossposted articles." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups) -(put 'gnus-header-newsgroups-face 'obsolete-face "22.1") (defface gnus-header-name '((((class color) @@ -827,9 +815,6 @@ articles." "Face used for displaying header names." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-name-face 'face-alias 'gnus-header-name) -(put 'gnus-header-name-face 'obsolete-face "22.1") (defface gnus-header-content '((((class color) @@ -842,9 +827,6 @@ articles." (:italic t))) "Face used for displaying header content." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-content-face 'face-alias 'gnus-header-content) -(put 'gnus-header-content-face 'obsolete-face "22.1") (defcustom gnus-header-face-alist '(("From" nil gnus-header-from) @@ -3628,8 +3610,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)))) @@ -5220,7 +5201,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))))) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index c3e77ca59b0..1cdfea625fc 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -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) diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index 386593be026..07a84940269 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -136,9 +136,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 +154,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 +165,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 +176,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 +187,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 +198,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 +209,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 +220,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 +231,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 +242,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 +253,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 +264,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 diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index 284fdca494e..ac5ff7d47cf 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -76,7 +76,7 @@ (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) @@ -225,7 +225,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 @@ -362,6 +362,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." @@ -492,7 +494,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-group.el b/lisp/gnus/gnus-group.el index fea09ea21a5..3e655cc56cd 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -1086,6 +1086,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'. @@ -1359,6 +1361,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 @@ -2998,7 +3002,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 +3025,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))))) @@ -4565,7 +4569,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..5d07a823f61 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -99,11 +99,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..48cffdb7388 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -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 diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el index c8ba7ae5c15..32433816e4c 100644 --- a/lisp/gnus/gnus-range.el +++ b/lisp/gnus/gnus-range.el @@ -38,17 +38,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 +447,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..07e80f3ca96 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -844,21 +844,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) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index a6536797662..ad11ff4a5c5 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -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)) @@ -2318,7 +2318,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 +2517,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 +2553,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 +2734,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 +3065,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)) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index f9795628cc0..6c6c3b7e30e 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -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 @@ -1127,7 +1114,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 +1134,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 +1144,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-sum.el b/lisp/gnus/gnus-sum.el index a39af45e92e..468f2b195e2 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -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])))) @@ -2940,6 +2944,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'. @@ -3992,7 +3998,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. @@ -5737,7 +5743,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 +5920,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 +6082,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 @@ -11962,7 +11968,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") @@ -12270,21 +12276,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 @@ -12915,7 +12927,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,7 +13014,7 @@ 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) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index 0ff25ecd3b5..ddaace9a24d 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -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. @@ -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) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 1c42d7d0ef8..8983132bfb3 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1117,41 +1117,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." diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 28fd66ca75e..fd0c7181951 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -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..fb2ae192f14 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,29 +347,16 @@ 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) (background dark)) - (:foreground "turquoise")) + (:foreground "turquoise4")) (((class color) (background light)) (:foreground "CadetBlue4")) @@ -391,114 +364,62 @@ 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) (background dark)) - ()) + (:foreground "turquoise3")) (((class color) (background light)) - ()) + (:foreground "DeepSkyBlue4")) (t ())) "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) (background dark)) - ()) + (:foreground "turquoise2")) (((class color) (background light)) - ()) + (:foreground "DeepSkyBlue3")) (t ())) "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) (background dark)) - ()) + (:foreground "turquoise1")) (((class color) (background light)) - ()) + (:foreground "DeepSkyBlue2")) (t ())) "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/message.el b/lisp/gnus/message.el index 0eebbe299d2..e452c80e262 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -28,8 +28,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mailheader) (require 'gmm-utils) @@ -1436,8 +1435,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 +1447,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 +1459,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 +1471,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 +1483,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 +1495,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 +1507,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 +1519,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 +1531,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 +1543,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) "\\)$") @@ -2434,7 +2412,7 @@ Return the number of headers removed." (not (looking-at regexp)) (looking-at regexp)) (progn - (incf number) + (cl-incf number) (when first (setq last t)) (delete-region @@ -2459,10 +2437,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." @@ -2842,8 +2820,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 '(":-)" ":)" @@ -2950,7 +2927,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 @@ -2958,7 +2935,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) @@ -3092,17 +3071,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 @@ -3121,12 +3098,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 () @@ -3217,13 +3194,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) @@ -3584,7 +3561,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) @@ -3752,13 +3729,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? @@ -4381,7 +4358,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) @@ -4603,9 +4580,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) @@ -4759,7 +4736,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) @@ -4790,7 +4767,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) @@ -5313,7 +5290,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? ") @@ -5840,10 +5819,10 @@ subscribed address (and not the additional To and Cc header contents)." message-subscribed-address-functions)))) (save-match-data (let ((list - (loop for recipient in recipients - when (loop for regexp in mft-regexps - thereis (string-match regexp recipient)) - return recipient))) + (cl-loop for recipient in recipients + when (cl-loop for regexp in mft-regexps + thereis (string-match regexp recipient)) + return recipient))) (when list (if only-show-subscribed list @@ -6192,7 +6171,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 @@ -6717,9 +6696,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 @@ -7875,6 +7854,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'. @@ -7901,6 +7882,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\\):" @@ -8124,11 +8106,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)) @@ -8224,16 +8207,19 @@ From headers in the original article." (autoload 'ecomplete-display-matches "ecomplete") +(defun message--in-tocc-p () + (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) + (message-point-in-header-p) + (save-excursion + (beginning-of-line) + (while (and (memq (char-after) '(?\t ? )) + (zerop (forward-line -1)))) + (looking-at "To:\\|Cc:")))) + (defun message-display-abbrev (&optional choose) "Display the next possible abbrev for the text before point." (interactive (list t)) - (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) - (message-point-in-header-p) - (save-excursion - (beginning-of-line) - (while (and (memq (char-after) '(?\t ? )) - (zerop (forward-line -1)))) - (looking-at "To:\\|Cc:"))) + (when (message--in-tocc-p) (let* ((end (point)) (start (save-excursion (and (re-search-backward "[\n\t ]" nil t) @@ -8246,6 +8232,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--- diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 87941b88450..372b6da44b5 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. @@ -773,15 +773,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 +962,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 +983,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 +1033,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 +1166,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 +1298,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 +1442,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 +1777,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,10 +1836,11 @@ 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) @@ -1865,7 +1862,7 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t) ;; 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-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-util.el b/lisp/gnus/mm-util.el index fcd97f2b27c..98f993367ef 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)) @@ -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,40 +612,18 @@ 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." @@ -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 diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 099e5372b48..dc10763da86 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -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.el b/lisp/gnus/mml.el index 3c9476333fa..38be0dc4e4c 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -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)) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 2d3d3d16a84..04bb3b56530 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -1532,7 +1532,7 @@ all. This may very well take some time.") ;; past. A permanent schedule never expires. (and sched (setq sched (nndiary-last-occurrence sched)) - (time-less-p sched (current-time)))) + (time-less-p sched nil))) ;; else (nnheader-report 'nndiary "Could not read file %s" file) nil) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index 55e00a0b69f..0a7d8296147 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -644,7 +644,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 +669,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 +718,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 +757,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 +807,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 +823,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 +961,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 +1182,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 +1272,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 +1438,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 +1507,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)." @@ -1667,7 +1672,7 @@ actually)." "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))) +;; (server (cadr (gnus-server-to-method srv))) (groupspec (mapconcat (lambda (x) (if (string-match-p "gmane" x) @@ -1809,8 +1814,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 "")) @@ -1851,7 +1855,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 +1890,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 +1911,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..1462578ec20 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -1883,7 +1883,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)) @@ -2034,7 +2034,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..3e4a87cee77 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -814,7 +814,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))) @@ -915,7 +915,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 diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 3ab7d0893b9..a04ede67844 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -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))) diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el index 9ef0598ee09..0ac56a9a3d9 100644 --- a/lisp/gnus/score-mode.el +++ b/lisp/gnus/score-mode.el @@ -85,7 +85,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/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..71a69cb5f01 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -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." diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 9ffb7ff59cd..a592809de6a 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -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. diff --git a/lisp/help-mode.el b/lisp/help-mode.el index 68fc319e68c..4fb3fb85c99 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 014af5141e3..e9235460329 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. @@ -455,6 +455,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 +467,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 +477,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 +595,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 +631,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 +718,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 +735,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. @@ -1118,9 +1059,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 +1081,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..4ec24cea70a 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,7 @@ ;;; Code: -(defconst hfy-fallback-colour-map +(defconst hfy-fallback-color-map '(("snow" 65535 64250 64250) ("ghost white" 63736 63736 65535) ("GhostWhite" 63736 63736 65535) @@ -785,8 +785,14 @@ ("DarkRed" 35723 0 0) ("light green" 37008 61166 37008) ("LightGreen" 37008 61166 37008)) ) +(define-obsolete-variable-alias + 'hfy-fallback-colour-map + 'hfy-fallback-color-map "27.1") -(defvar hfy-rgb-txt-colour-map nil) +(defvar hfy-rgb-txt-color-map nil) +(define-obsolete-variable-alias + 'hfy-rgb-txt-colour-map + 'hfy-rgb-txt-color-map "27.1") (defvar hfy-rgb-load-path (list "/etc/X11" @@ -806,8 +812,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 +828,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/htmlfontify.el b/lisp/htmlfontify.el index dfa6bde2972..23efcd1298a 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -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 2023165b2a6..91d9acb3a3c 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..38fffcb976b 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -522,6 +522,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) diff --git a/lisp/ido.el b/lisp/ido.el index da0c9d463d1..7ff3d6820b4 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.") @@ -3480,6 +3483,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 +4853,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..59e333f19c1 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -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 1052ed97613..70d2ca87cc6 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -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, diff --git a/lisp/image.el b/lisp/image.el index b021edb33dc..b69bf930545 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 @@ -976,11 +977,12 @@ default is 20%." 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) @@ -1000,6 +1002,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 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/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/international/fontset.el b/lisp/international/fontset.el index 6f912074517..4a7b7547919 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -1144,6 +1144,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/mule-cmds.el b/lisp/international/mule-cmds.el index aeba954a3b2..f737869eef8 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] @@ -355,8 +354,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 +1156,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. @@ -1800,6 +1795,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 +1895,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 +1973,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." @@ -2665,12 +2654,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-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..96faa27c174 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -67,8 +67,23 @@ (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. +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 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 "Don't terminate incremental search" nil)) + :version "27.1") (defcustom search-slow-window-lines 1 "Number of lines in slow search display windows. @@ -480,7 +495,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) @@ -589,8 +605,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 @@ -1233,6 +1249,8 @@ If this is set inside code wrapped by the macro (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. You can update the global isearch variables by setting new values to @@ -1299,6 +1317,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 +1333,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 @@ -1374,6 +1396,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 ))) @@ -1846,11 +1869,11 @@ replacements from Isearch is `M-s w ... M-%'." (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 +1936,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" ()) @@ -2081,22 +2105,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 +2406,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 +2414,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,6 +2444,14 @@ 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) + (eq (get this-command 'isearch-move) t)) + (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))) ;; Other characters terminate the search and are then executed normally. (search-exit-option (isearch-done) @@ -2423,13 +2461,28 @@ before the command is executed globally with terminated Isearch." (isearch-process-search-string key key))))) (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))) + (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. @@ -2851,7 +2904,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) diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 8855fa5c314..76d2125c9d8 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 @@ -261,7 +254,7 @@ previous `kmacro-counter', and do not modify counter." (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)))) @@ -280,8 +273,8 @@ previous `kmacro-counter', and do not modify counter." (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 `kmacro-counter' to ARG or prompt if missing. @@ -780,19 +773,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] @@ -833,6 +825,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. @@ -843,14 +842,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)) @@ -1209,7 +1212,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) @@ -1229,17 +1232,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)))) @@ -1262,9 +1265,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 95d5be7734b..4ad6b5c4eb1 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -5765,7 +5765,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 @@ -8100,12 +8100,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-"))) ;;;*** @@ -8334,7 +8338,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 +8460,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. @@ -10616,10 +10620,9 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL. ;;;*** -;;;### (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 +10635,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 +10705,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-"))) @@ -10839,110 +10736,41 @@ system. ;;;*** -;;;### (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 +10796,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"))) ;;;*** -;;;### (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-"))) @@ -12390,6 +12147,49 @@ Besides the choice of face, it is the same as `buffer-face-mode'. ;;;*** +;;;### (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-"))) + +;;;*** + ;;;### (autoloads nil "feedmail" "mail/feedmail.el" (0 0 0 0)) ;;; Generated autoloads from mail/feedmail.el (push (purecopy '(feedmail 11)) package--builtin-versions) @@ -12549,7 +12349,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 @@ -13471,7 +13271,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-"))) ;;;*** @@ -15349,7 +15149,7 @@ 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-" "rgrep-" "kill-grep"))) ;;;*** @@ -16803,7 +16603,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" '("ibuffer-" "file" "shell-command-" "starred-name" "size" "alphabetic" "major-mode" "mod" "print" "process" "predicate" "content" "view-and-eval" "visiting-file" "derived-mode" "directory" "basename" "name" "used-mode" "query-replace" "rename-uniquely" "revert" "replace-regexp" "eval"))) ;;;*** @@ -17002,7 +16802,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 +16815,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-"))) @@ -17541,6 +17341,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) @@ -18280,7 +18082,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. @@ -20011,13 +19813,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. @@ -22224,7 +22020,7 @@ QUALITY can be: ;;;### (autoloads nil "mwheel" "mwheel.el" (0 0 0 0)) ;;; Generated autoloads from mwheel.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mwheel" '("mwheel-" "mouse-wheel-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mwheel" '("mouse-wheel-" "mwheel-"))) ;;;*** @@ -24621,8 +24417,6 @@ 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. @@ -25278,7 +25072,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"))) @@ -26634,7 +26428,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)) @@ -30056,13 +29850,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 @@ -33071,10 +32858,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) @@ -33652,7 +33437,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" '("filename" "form-at-point" "thing-at-point-" "sentence-at-point" "word-at-point" "define-thing-chars" "in-string-p" "end-of-thing" "beginning-of-thing"))) ;;;*** @@ -34496,14 +34281,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.") @@ -34524,6 +34309,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" "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 @@ -34561,7 +34375,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-"))) ;;;*** @@ -34588,7 +34402,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 3 26 1)) package--builtin-versions) +(push (purecopy '(tramp 2 4 0 -1)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trampver" '("tramp-"))) @@ -36393,7 +36207,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-"))) @@ -38262,10 +38076,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-"))) @@ -38656,52 +38471,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/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/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..83042b42e87 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 ?\() diff --git a/lisp/mail/rfc2047.el b/lisp/mail/rfc2047.el index dbfde57224a..c0cd4ee8c43 100644 --- a/lisp/mail/rfc2047.el +++ b/lisp/mail/rfc2047.el @@ -290,8 +290,7 @@ 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 @@ -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..4da3641893b 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,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'ietf-drums) (require 'rfc2047) (autoload 'mm-encode-body "mm-bodies") @@ -181,7 +180,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 +290,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.el b/lisp/mail/rmail.el index 6b0c93d60cb..4e5873c06ee 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -1331,8 +1331,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 +1758,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 +3398,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. diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el index b6d0b53ce06..212a6c74baa 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -243,15 +243,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. @@ -616,7 +607,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)) @@ -1718,8 +1709,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 +1777,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. diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 571089d2144..403a5c35518 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.") @@ -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")) 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/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..941529330e1 100644 --- a/lisp/mh-e/mh-comp.el +++ b/lisp/mh-e/mh-comp.el @@ -305,17 +305,19 @@ 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 @@ -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-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 e8c6ce6910b..9b6f043b576 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))) @@ -1319,7 +1320,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 () @@ -1823,12 +1824,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' @@ -1836,7 +1832,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. @@ -2955,6 +2951,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))) @@ -2986,6 +2984,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'." @@ -3017,7 +3026,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) @@ -3025,8 +3035,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..6a98ee7353f 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -58,8 +58,8 @@ addition to mouse drags." 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 @@ -96,55 +96,55 @@ point at the click position." :version "22.1" :group 'mouse) +(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))) + (vector (cons newup (cdr 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. @@ -1144,19 +1144,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 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/net/ange-ftp.el b/lisp/net/ange-ftp.el index e62bee4499e..b1e0bf24aa8 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) @@ -3373,6 +3373,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 +3411,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 +3452,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 +3840,7 @@ so return the size on the remote host exactly. See RFC 3659." (ange-ftp-call-cont cont result line))) (defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists - keep-date preserve-uid-gid + keep-date _preserve-uid-gid _preserve-selinux-context) (interactive "fCopy file: \nFCopy %s to file: \np") (ange-ftp-copy-file-internal filename @@ -4385,10 +4396,13 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (put 'directory-files-and-attributes 'ange-ftp 'ange-ftp-directory-files-and-attributes) (put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p) +(put 'file-accessible-directory-p 'ange-ftp + 'ange-ftp-file-accessible-directory-p) (put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p) (put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p) (put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p) (put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p) +(put 'file-regular-p 'ange-ftp 'ange-ftp-file-regular-p) (put 'delete-file 'ange-ftp 'ange-ftp-delete-file) (put 'verify-visited-file-modtime 'ange-ftp 'ange-ftp-verify-visited-file-modtime) @@ -4469,6 +4483,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 +4493,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 +5217,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 98b0acfc0c6..8086495aaaa 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 "[*\"()',=;?% ]")) 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..4ec00450f4e 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -1006,6 +1006,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/newst-backend.el b/lisp/net/newst-backend.el index 71a1e31d73a..520a9e19b42 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) @@ -1255,9 +1253,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 +1288,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 +1303,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 +1338,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 +1397,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 +1478,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 +1513,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 +1750,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 +1765,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 +1798,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 +1840,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 +1901,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 +1995,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 +2007,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 +2280,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 +2348,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 +2394,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 +2486,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/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/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/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/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/tramp-adb.el b/lisp/net/tramp-adb.el index 0395eb4380b..7a0ea71aee9 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -71,7 +71,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 @@ -114,7 +114,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) @@ -199,11 +199,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) @@ -245,16 +247,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." @@ -288,7 +282,7 @@ pass to the OPERATION." "%s%s" (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 (tramp-message v 4 "Finding true name for `%s'" filename) @@ -316,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) @@ -466,13 +458,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. @@ -549,8 +547,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))) @@ -560,11 +558,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") @@ -575,8 +573,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))) @@ -669,8 +667,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)) @@ -689,26 +687,35 @@ But handle the case, if the \"test\" command is not available." (tramp-error v 'file-error "Cannot write: `%s'" filename)) (delete-file tmpfile))) - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime)) - (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error - "Buffer has changed from `%s' to `%s'" curbuf (current-buffer)))))) + "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) + + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))) (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))) @@ -744,8 +751,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 @@ -779,8 +786,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) @@ -823,10 +831,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 @@ -861,8 +869,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))) @@ -895,8 +902,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")))) @@ -940,7 +946,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) @@ -1046,7 +1052,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (or (null program) tramp-process-connection-type)) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0)) + (i 0) + ;; We do not want to run timers. + timer-list timer-idle-list) (while (get-process name1) ;; NAME must be unique as process name. @@ -1097,8 +1105,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. @@ -1107,7 +1115,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)) @@ -1252,10 +1260,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. @@ -1285,7 +1289,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) @@ -1324,7 +1328,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..0b5a351deaa --- /dev/null +++ b/lisp/net/tramp-archive.el @@ -0,0 +1,638 @@ +;;; 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: + +(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." + (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. + (unless tramp-archive-enabled + (tramp-compat-user-error nil "Package `tramp-archive' not supported")) + (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-compat-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 b95d2935926..97c687598f2 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -98,10 +98,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))) @@ -117,8 +114,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) @@ -169,7 +165,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))) @@ -184,10 +195,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)) @@ -206,7 +217,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 @@ -225,7 +236,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) @@ -294,7 +305,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 @@ -387,6 +415,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 ef9aca723de..cbb9cd37005 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -49,7 +49,7 @@ SYNTAX can be one of the symbols `default' (default), (unless (string-equal input "") (list (intern input))))) (when syntax - (custom-set-variables `(tramp-syntax ',syntax)))) + (customize-set-variable 'tramp-syntax syntax))) (defun tramp-list-tramp-buffers () "Return a list of all Tramp connection buffers." @@ -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)))) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 5bf57638ff8..4f564e6eb5c 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 @@ -190,11 +189,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 +237,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 f370abba319..eb3dddcd6c5 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -49,15 +49,21 @@ ;; 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. +;; "davs", "gdrive", "obex", "owncloud", "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. + +;; "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 @@ -69,7 +75,7 @@ ;; 'car ;; (dbus-call-method ;; :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker -;; tramp-gvfs-interface-mounttracker "listMountableInfo"))) +;; tramp-gvfs-interface-mounttracker "ListMountableInfo"))) ;; Note that all other connection methods are not tested, beside the ;; ones offered for customization in `tramp-gvfs-methods'. If you @@ -108,9 +114,19 @@ (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" "obex" "owncloud" "sftp" "synce") "List of methods for remote files, accessed with GVFS." :group 'tramp :version "26.1" @@ -119,12 +135,24 @@ (const "davs") (const "ftp") (const "gdrive") + (const "http") + (const "https") (const "obex") + (const "owncloud") (const "sftp") (const "smb") (const "synce"))) :require 'tramp) +(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 (when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)" @@ -158,16 +186,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.") @@ -289,6 +307,162 @@ It has been changed in GVFS 1.14.") (defconst tramp-gvfs-password-anonymous-supported 16 "Operation supports anonymous users.") +;; For the time being, we just need org.goa.Account and org.goa.Files +;; interfaces. We document the other ones, just in case. + +;;;###tramp-autoload +(defconst tramp-goa-service "org.gnome.OnlineAccounts" + "The well known name of the GNOME Online Accounts service.") + +(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-goa-interface-printers "org.gnome.OnlineAccounts.Printers" + "The printers interface of the GNOME Online Accounts.") + +;; <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> +;; <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> +;; <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> + +(defconst tramp-goa-identity-regexp + (concat "^" "\\(" tramp-user-regexp "\\)?" + "@" "\\(" tramp-host-regexp "\\)?" + "\\(?:" ":""\\(" tramp-port-regexp "\\)" "\\)?") + "Regexp matching GNOME Online Accounts \"PresentationIdentity\" property.") + +(defconst tramp-goa-interface-mail "org.gnome.OnlineAccounts.Mail" + "The mail interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Mail'> +;; <property type='s' name='EmailAddress' access='read'/> +;; <property type='s' name='Name' access='read'/> +;; <property type='b' name='ImapSupported' access='read'/> +;; <property type='b' name='ImapAcceptSslErrors' access='read'/> +;; <property type='s' name='ImapHost' access='read'/> +;; <property type='b' name='ImapUseSsl' access='read'/> +;; <property type='b' name='ImapUseTls' access='read'/> +;; <property type='s' name='ImapUserName' access='read'/> +;; <property type='b' name='SmtpSupported' access='read'/> +;; <property type='b' name='SmtpAcceptSslErrors' access='read'/> +;; <property type='s' name='SmtpHost' access='read'/> +;; <property type='b' name='SmtpUseAuth' access='read'/> +;; <property type='b' name='SmtpAuthLogin' access='read'/> +;; <property type='b' name='SmtpAuthPlain' access='read'/> +;; <property type='b' name='SmtpAuthXoauth2' access='read'/> +;; <property type='b' name='SmtpUseSsl' access='read'/> +;; <property type='b' name='SmtpUseTls' access='read'/> +;; <property type='s' name='SmtpUserName' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-chat "org.gnome.OnlineAccounts.Chat" + "The chat interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Chat'> +;; </interface> + +(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-goa-path-manager (concat tramp-goa-path "/Manager") + "The object path of the GNOME Online Accounts manager.") + +(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Manager" + "The manager interface of the GNOME Online Accounts.") + +;; <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> + +;; 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) + (defconst tramp-bluez-service "org.bluez" "The well known name of the BLUEZ service.") @@ -424,11 +598,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" @@ -473,6 +649,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 @@ -495,7 +678,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) @@ -604,12 +787,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. @@ -618,22 +813,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 @@ -642,7 +849,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 @@ -675,6 +882,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) @@ -738,13 +946,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 @@ -778,8 +986,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") @@ -793,8 +1001,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") @@ -1043,11 +1251,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 @@ -1083,9 +1286,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)) @@ -1100,67 +1304,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)) @@ -1178,7 +1393,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))) @@ -1203,8 +1418,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 @@ -1260,8 +1475,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)) @@ -1270,7 +1485,8 @@ file-notify events." (file-attributes filename)))) ;; The end. - (when (or (eq visit t) (null visit) (stringp visit)) + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook))) @@ -1279,7 +1495,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) @@ -1290,6 +1506,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 @@ -1314,24 +1534,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. @@ -1363,13 +1565,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. @@ -1408,7 +1604,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 "" @@ -1449,6 +1645,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 @@ -1464,31 +1661,35 @@ 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))))))) @@ -1531,6 +1732,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 @@ -1546,39 +1748,59 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) - (prefix (concat - (tramp-gvfs-dbus-byte-array-to-string - (car mount-spec)) - (tramp-gvfs-dbus-byte-array-to-string - (or - (cadr (assoc "share" (cadr mount-spec))) - (cadr (assoc "volume" (cadr mount-spec)))))))) + (uri (tramp-gvfs-dbus-byte-array-to-string + (cadr (assoc "uri" (cadr mount-spec))))) + (share (tramp-gvfs-dbus-byte-array-to-string + (or + (cadr (assoc "share" (cadr mount-spec))) + (cadr (assoc "volume" (cadr mount-spec))))))) (when (string-match "^\\(afp\\|smb\\)" method) (setq method (match-string 1 method))) (when (string-equal "obex" method) (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) + (when (and (string-equal "davs" method) + (string-match + 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})\"." @@ -1597,7 +1819,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 @@ -1609,7 +1831,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (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))) @@ -1620,7 +1842,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 @@ -1630,10 +1859,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))) @@ -1685,6 +1914,21 @@ ID-FORMAT valid values are `string' and `integer'." (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 @@ -1701,6 +1945,7 @@ 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) @@ -1746,7 +1991,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" @@ -1836,11 +2082,84 @@ 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 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 BLUEZ functions. +(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))))))) + (defun tramp-bluez-list-devices () "Return all discovered bluetooth devices as list. Every entry is a list (NAME ADDRESS). @@ -2042,8 +2361,10 @@ 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. ;; ;; * Check, how two shares of the same SMB server can be mounted in ;; parallel. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 9b74da65805..f619ac30633 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -962,15 +962,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 \")\"" @@ -1104,8 +1105,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 @@ -1500,8 +1501,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 @@ -1512,8 +1513,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))) @@ -1605,8 +1606,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) @@ -1646,7 +1646,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. @@ -1940,8 +1940,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 @@ -2007,8 +2007,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) @@ -2055,6 +2055,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))))) @@ -2133,14 +2134,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. @@ -2362,15 +2365,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) @@ -2481,7 +2475,9 @@ The method used must be an out-of-band method." ;; The default directory must be remote. (let ((default-directory (file-name-directory (if t1 filename newname))) - (process-environment (copy-sequence process-environment))) + (process-environment (copy-sequence process-environment)) + ;; We do not want to run timers. + timer-list timer-idle-list) ;; Set the transfer process properties. (tramp-set-connection-property v "process-name" (buffer-name (current-buffer))) @@ -2513,7 +2509,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) @@ -2524,8 +2520,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))) @@ -2556,7 +2552,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" @@ -2568,8 +2564,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)) @@ -2581,8 +2577,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") @@ -2595,7 +2591,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) @@ -2828,11 +2824,11 @@ the result will be a local, non-Tramp, file name." (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 @@ -2866,13 +2862,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'. @@ -2908,7 +2898,9 @@ the result will be a local, non-Tramp, file name." ;; We do not want to raise an error when ;; `start-file-process' has been started several times in ;; `eshell' and friends. - (tramp-current-connection nil) + tramp-current-connection + ;; We do not want to run timers. + timer-list timer-idle-list p) (while (get-process name1) @@ -2972,8 +2964,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) @@ -3095,7 +3087,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) @@ -3399,8 +3391,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. @@ -3420,7 +3412,8 @@ the result will be a local, non-Tramp, file name." ;; Set the ownership. (when need-chown (tramp-set-file-uid-gid filename uid gid)) - (when (or (eq visit t) (null visit) (stringp visit)) + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook))))) @@ -3572,19 +3565,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 @@ -3602,6 +3583,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 @@ -3621,7 +3626,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) @@ -3632,9 +3637,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." @@ -3650,8 +3713,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]*" @@ -3697,12 +3758,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 @@ -4036,7 +4096,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 @@ -4124,7 +4184,7 @@ process to set up. VEC specifies the connection." (memq 'utf-8-hfs (coding-system-list))) (setq cs-decode 'utf-8-hfs cs-encode 'utf-8-hfs)) - (set-buffer-process-coding-system cs-decode cs-encode) + (set-process-coding-system proc cs-decode cs-encode) (tramp-message vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode))) @@ -4470,13 +4530,14 @@ Goes through the list `tramp-inline-compress-commands'." (zerop (tramp-call-local-coding-command (format + "echo %s | %s | %s" magic ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. - (if (memq system-type '(windows-nt)) - "echo %s | \"%s\" | \"%s\"" - "echo %s | %s | %s") - magic compress decompress) + (mapconcat + 'shell-quote-argument (split-string compress) " ") + (mapconcat + 'shell-quote-argument (split-string decompress) " ")) nil nil)) (throw 'next nil)) (tramp-message @@ -4727,7 +4788,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)) @@ -4750,13 +4812,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) " ")) @@ -4810,16 +4871,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 @@ -5244,14 +5305,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)) x)) remote-path))))) @@ -5471,6 +5525,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 59db6ee6071..eab0da54b6d 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -151,6 +151,7 @@ call, letting the SMB client use the default one." "NT_STATUS_OBJECT_NAME_NOT_FOUND" "NT_STATUS_OBJECT_PATH_SYNTAX_BAD" "NT_STATUS_PASSWORD_MUST_CHANGE" + "NT_STATUS_RESOURCE_NAME_NOT_FOUND" "NT_STATUS_SHARING_VIOLATION" "NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE" "NT_STATUS_UNSUCCESSFUL" @@ -228,10 +229,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) @@ -370,8 +371,8 @@ pass to the OPERATION." (delete-file newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) + (tramp-flush-file-properties v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) (unless (tramp-smb-send-command v1 @@ -449,13 +450,6 @@ pass to the OPERATION." (if (not (file-directory-p newname)) (make-directory newname parents)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (let* ((share (tramp-smb-get-share v)) (localname (file-name-as-directory (replace-regexp-in-string @@ -464,7 +458,9 @@ pass to the OPERATION." (expand-file-name tramp-temp-name-prefix (tramp-compat-temporary-file-directory)))) - (args (list (concat "//" host "/" share) "-E"))) + (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))) @@ -524,7 +520,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) @@ -534,8 +530,8 @@ pass to the OPERATION." (tramp-message v 6 "\n%s" (buffer-string)))) ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") (when t1 (delete-directory tmpdir 'recursive)))) ;; Handle KEEP-DATE argument. @@ -552,8 +548,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 @@ -598,8 +594,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)) @@ -633,8 +629,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\"" @@ -654,8 +650,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\"" @@ -739,62 +735,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))) - (args (list (concat "//" host "/" share) "-E"))) - - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) - - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (setq - args - (append args (list (tramp-unquote-shell-quote-argument localname) - "2>/dev/null"))) - - (unwind-protect - (with-temp-buffer - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - - ;; Use an asynchronous processes. By this, password - ;; can be handled. - (let ((p (apply - 'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-acl-program args))) - - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) - (process-put p 'adjust-window-size-function 'ignore) - (set-process-query-on-exit-flag p nil) - (tramp-process-actions p v nil tramp-smb-actions-get-acl) - (when (> (point-max) (point-min)) - (substring-no-properties (buffer-string))))) - - ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))))) + (ignore-errors + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-acl" + (when (executable-find tramp-smb-acl-program) + (let* ((share (tramp-smb-get-share v)) + (localname (replace-regexp-in-string + "\\\\" "/" (tramp-smb-get-localname v))) + (args (list (concat "//" host "/" share) "-E")) + ;; 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 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." @@ -911,13 +903,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 @@ -1164,8 +1149,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)))))) @@ -1211,8 +1196,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 @@ -1222,7 +1207,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) @@ -1235,6 +1220,8 @@ component is used as the target of the symlink." (let* ((name (file-name-nondirectory program)) (name1 name) (i 0) + ;; We do not want to run timers. + timer-list timer-idle-list input tmpinput outbuf command ret) ;; Determine input. @@ -1327,14 +1314,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) @@ -1370,10 +1357,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)) @@ -1403,21 +1390,17 @@ component is used as the target of the symlink." "Like `set-file-acl' for Tramp files." (ignore-errors (with-parsed-tramp-file-name filename nil - (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (tramp-set-file-property v localname "file-acl" 'undef) + (tramp-flush-file-property v localname "file-acl") + (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) (let* ((share (tramp-smb-get-share v)) (localname (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" host "/" share) "-E" "-S" (replace-regexp-in-string - "\n" "," acl-string)))) + "\n" "," acl-string))) + ;; We do not want to run timers. + timer-list timer-idle-list) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -1451,7 +1434,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) @@ -1470,14 +1453,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 @@ -1497,7 +1480,9 @@ component is used as the target of the symlink." (command (mapconcat 'identity (cons program args) " ")) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0)) + (i 0) + ;; We do not want to run timers. + timer-list timer-idle-list) (unwind-protect (save-excursion (save-restriction @@ -1530,8 +1515,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. @@ -1564,8 +1549,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)) @@ -1589,9 +1574,18 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-error v 'file-error "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) - (when (eq visit t) - (set-visited-file-modtime))))) + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))) ;; Internal file name functions. @@ -1889,8 +1883,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))) @@ -1967,17 +1961,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. @@ -1998,8 +1985,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 c4839e7f697..fe9f1976944 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) @@ -349,7 +350,7 @@ This variable is regarded as obsolete, and will be removed soon." "Default user to use for specific method/host pairs. This is an alist of items (METHOD HOST USER). The first matching item specifies the user to use for a file name which does not specify a -user. METHOD and USER are regular expressions or nil, which is +user. METHOD and HOST are regular expressions or nil, which is interpreted as a regular expression which always matches. If no entry matches, the variable `tramp-default-user' takes effect. @@ -373,7 +374,7 @@ Useful for su and sudo methods mostly." "Default host to use for specific method/user pairs. This is an alist of items (METHOD USER HOST). The first matching item specifies the host to use for a file name which does not specify a -host. METHOD and HOST are regular expressions or nil, which is +host. METHOD and USER are regular expressions or nil, which is interpreted as a regular expression which always matches. If no entry matches, the variable `tramp-default-host' takes effect. @@ -1182,21 +1183,6 @@ 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.") @@ -1390,7 +1376,7 @@ values." (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." @@ -1401,30 +1387,65 @@ values." (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." - (concat tramp-prefix-format hop - (unless (or (zerop (length method)) - (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 @@ -1451,15 +1472,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 "/" 'nohop)) (current-buffer)))) (defun tramp-get-connection-buffer (vec) @@ -1545,7 +1559,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) @@ -1614,10 +1630,11 @@ ARGUMENTS to actually emit the message (if applicable)." ;; The message. (insert (apply #'format-message fmt-string arguments)))) -(defvar tramp-message-show-message t +(defvar tramp-message-show-message (null noninteractive) "Show Tramp message in the minibuffer. -This variable is used to disable messages from `tramp-error'. -The messages are visible anyway, because an error is raised.") +This variable is used to suppress progress reporter output, and +to disable messages from `tramp-error'. Those messages are +visible anyway, because an error is raised.") (defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) "Emit a message depending on verbosity level. @@ -1649,17 +1666,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 @@ -2052,6 +2070,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 . @@ -2217,6 +2236,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 @@ -2240,6 +2261,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 @@ -2352,15 +2375,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)) @@ -2374,6 +2401,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)) @@ -2427,6 +2460,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)))))) @@ -2488,7 +2522,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. @@ -2926,8 +2959,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))) @@ -2971,13 +3004,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 @@ -3018,17 +3057,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 (unless (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) ""))))))) (defun tramp-handle-file-name-case-insensitive-p (filename) "Like `file-name-case-insensitive-p' for Tramp files." @@ -3087,10 +3120,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 @@ -3116,14 +3145,8 @@ User is always nil." (let ((v (tramp-dissect-file-name file t))) ;; Run the command on the localname portion only. (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 (tramp-run-real-handler + 'file-name-directory (list (or (tramp-file-name-localname v) "")))))) (defun tramp-handle-file-name-nondirectory (file) "Like `file-name-nondirectory' but aware of Tramp files." @@ -3162,7 +3185,8 @@ 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) @@ -3530,17 +3554,19 @@ 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) + (substitute-in-file-name 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." @@ -3574,34 +3600,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 @@ -3633,17 +3664,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." @@ -3767,12 +3797,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 @@ -3823,7 +3851,9 @@ connection buffer." This is needed in order to hide `last-coding-system-used', which is set for process communication also." (with-current-buffer (process-buffer proc) - (let (buffer-read-only last-coding-system-used) + (let (buffer-read-only last-coding-system-used + ;; We do not want to run timers. + timer-list timer-idle-list) ;; Under Windows XP, `accept-process-output' doesn't return ;; sometimes. So we add an additional timeout. JUST-THIS-ONE ;; is set due to Bug#12145. It is an integer, in order to avoid @@ -4140,15 +4170,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)) @@ -4205,11 +4227,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 @@ -4219,14 +4237,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)) @@ -4339,15 +4352,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 @@ -4365,8 +4373,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 @@ -4376,15 +4384,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 @@ -4397,11 +4400,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 @@ -4411,8 +4414,11 @@ 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) @@ -4424,6 +4430,8 @@ Invokes `password-read' if available, `read-passwd' else." (unwind-protect (with-parsed-tramp-file-name key nil + (setq user + (or user (tramp-get-connection-property key "login-as" nil))) (prog1 (or ;; See if auth-sources contains something useful. @@ -4434,24 +4442,16 @@ Invokes `password-read' if available, `read-passwd' else." (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) + (and user :user) + (if domain + (concat user tramp-prefix-domain-format domain) + 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)))) + (if port + (concat host tramp-prefix-port-format port) + host) + :port method + :require (cons :secret (and user '(:user)))) auth-passwd (plist-get (nth 0 auth-info) :secret) auth-passwd (if (functionp auth-passwd) @@ -4459,6 +4459,7 @@ Invokes `password-read' if available, `read-passwd' else." auth-passwd)))) ;; Try the password cache. (let ((password (password-read pw-prompt key))) + ;; FIXME test password works before caching it. (password-cache-add key password) password) ;; Else, get the password interactively. @@ -4471,11 +4472,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 @@ -4490,8 +4487,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. @@ -4568,7 +4564,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 1a7727820ef..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.3.26.1 +;; 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.3.26.1" +(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.3.26.1 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 f5615d93df3..9eb6875772e 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -527,7 +527,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)) diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el index 7dc0be8c8ed..1df410e505d 100644 --- a/lisp/nxml/nxml-mode.el +++ b/lisp/nxml/nxml-mode.el @@ -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 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/iswitchb.el b/lisp/obsolete/iswitchb.el index ec92b96899a..55e81d08d1a 100644 --- a/lisp/obsolete/iswitchb.el +++ b/lisp/obsolete/iswitchb.el @@ -1247,7 +1247,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/org/org-element.el b/lisp/org/org-element.el index 9e5c4007bd7..a63aae5329d 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-pcomplete.el b/lisp/org/org-pcomplete.el index a7cc09def4b..1acb61590f4 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 a53553bfd8b..3ec6b4eabe3 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -19316,6 +19316,9 @@ INCLUDE-LINKED is passed to `org-display-inline-images'." (org-toggle-inline-images) (org-toggle-inline-images))) +;; For without-x builds. +(declare-function image-refresh "image" (spec &optional frame)) + (defun org-display-inline-images (&optional include-linked refresh beg end) "Display inline images. @@ -22905,7 +22908,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 cdee568fc81..1fc697a6a86 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/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..e7d12c63414 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -950,7 +950,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) @@ -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/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/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/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-engine.el b/lisp/progmodes/cc-engine.el index 317968aafd3..c5b07b37027 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -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? @@ -8605,6 +8614,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 +8644,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)) @@ -10516,6 +10534,17 @@ 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) + ((and c-has-compound-literals + (eq (char-after) ?,)) + (save-excursion + (when (and (c-go-up-list-backward nil lim) + (eq (char-after) ?\()) + (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 +10583,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 +10665,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 +10956,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 +11291,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 +11383,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 @@ -12428,6 +12460,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 diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index fa9b8f354ef..7cac55e057f 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -1234,10 +1234,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..f1ef89a76ad 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -617,6 +617,12 @@ EOL terminated statements." 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 @@ -2101,6 +2107,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. diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 6dbdba75de6..8c0682ac1c1 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 @@ -458,7 +443,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 +597,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 +994,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 +1022,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 +1049,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 +1185,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 +1213,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 +1262,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 +1272,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 +1301,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 +1330,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 +1339,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 +1389,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 +1413,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 +1586,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 +1681,74 @@ 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) + (or cperl-vc-header-alist ; Avoid warning + `((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 +1763,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 +1787,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 +1887,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 +1940,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 +2012,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 +2048,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 +2059,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 +2083,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 +2096,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 +2135,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 +2210,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 +2229,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 +2268,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 +2368,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 +2536,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 +2566,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 +2585,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 +2620,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 +2800,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 +2877,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 +2917,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 +2939,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 +3107,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 +3365,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 +3386,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 +3424,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 +3439,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 +3540,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 +3559,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 +3669,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 +3682,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 +3757,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 +3770,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 +3880,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 +4064,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 +4462,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 +4720,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 +4740,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 +4769,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 +4789,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 +4864,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 +4893,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 +4929,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 +5020,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 +5029,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 +5039,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 +5160,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 +5177,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 +5190,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 +5375,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 +5524,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 +5547,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 +5598,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 +5620,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 +5650,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 +5661,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 +5679,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 +5692,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 +5722,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 +5764,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 +5780,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 +5828,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 +5959,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 +6024,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 +6063,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 +6145,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 +6392,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 +6414,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 +6447,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 +6478,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 +6576,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 +6604,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 +6655,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 +6710,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 +6748,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 +6766,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 +6785,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 +6825,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 +6844,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 +6884,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 +6942,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 +6957,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 +6965,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 +7015,7 @@ Use as "^\\(" "\\(package\\)\\>" "\\|" - "sub\\>[^\n]+::" + cperl-sub-regexp "\\>[^\n]+::" "\\|" "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB? "\\|" @@ -7127,10 +7032,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 +7086,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 +7120,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 +7139,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 +7179,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 +7205,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 +7231,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 +7249,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 +7257,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 +7274,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 +7296,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 +7319,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 +7348,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 +7448,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 +7615,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 +7653,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 +7661,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 +7677,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 +7694,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 +7731,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 +7792,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 +7827,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 +7863,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 +7884,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 +7896,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 +7919,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 +7943,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 +8139,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 +8217,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 +8429,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 +8460,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 +8479,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 +8496,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 +8560,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 +8569,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 +8618,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 +8654,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 +8667,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 +8730,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 +8807,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 +8868,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/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-proc.el b/lisp/progmodes/flymake-proc.el index c5bb79fee66..f842563be24 100644 --- a/lisp/progmodes/flymake-proc.el +++ b/lisp/progmodes/flymake-proc.el @@ -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. @@ -203,17 +213,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." diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 40eacdd1888..56f43e4bb36 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -419,6 +419,8 @@ Currently accepted REPORT-KEY arguments are: * `:force': value should be a boolean suggesting that Flymake consider the report even if it was somehow unexpected.") +(put 'flymake-diagnostic-functions 'safe-local-variable #'null) + (defvar flymake-diagnostic-types-alist `((:error . ((flymake-category . flymake-error))) 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/grep.el b/lisp/progmodes/grep.el index da09c900e58..dc74ad2de5f 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -433,6 +433,26 @@ See `compilation-error-regexp-alist' for format details.") help-echo "Number of matches so far") "]")) +(defcustom grep-find-hide 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." + :type 'boolean + :version "27.1" + :group 'grep) + +(defvar grep-find-hide-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-show) + (define-key map "\C-m" 'grep-find-show) + `(face nil display ,ellipsis mouse-face highlight + help-echo "RET, mouse-2: show unabbreviated command" + keymap ,map)) + "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 +470,16 @@ 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 (when grep-find-hide grep-find-hide-properties))) + ;; Hide excessive part of lgrep command + ("^grep \\( *--exclude.*--exclude[^ ]+\\)" + (1 (when grep-find-hide grep-find-hide-properties)))) "Additional things to highlight in grep output. This gets tacked on the end of the generated expressions.") @@ -1168,6 +1195,24 @@ to specify a command to run." (shell-quote-argument ")") " -prune -o "))))) +(defun grep-find-show () + "Show the hidden part of rgrep/lgrep/zrgrep command line." + (interactive) + (when (get-text-property (point) 'display) + (let ((beg (or (previous-single-property-change + (min (point-max) (1+ (point))) 'display) + (point))) + (end (or (next-single-property-change + (point) 'display) + (point))) + (inhibit-modification-hooks t) + (inhibit-read-only t) + (buffer-undo-list t) + (modified (buffer-modified-p))) + (remove-list-of-text-properties + beg end '(display help-echo mouse-face help-echo keymap)) + (set-buffer-modified-p modified)))) + ;;;###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 15b428bb68b..6aa9a7e4d4a 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) 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/idlwave.el b/lisp/progmodes/idlwave.el index 1d5dc7c7948..a1ea6db64f2 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -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)))) 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/octave.el b/lisp/progmodes/octave.el index c768d8d6f4d..f5d764e16c3 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -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/perl-mode.el b/lisp/progmodes/perl-mode.el index 99480788f50..c1d94acfa59 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -165,7 +165,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.") diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index c7bb2d97c84..afafd1b42cd 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))) @@ -3183,10 +3196,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 @@ -5286,6 +5299,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 +5395,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/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 d20c579f660..9bb2cf4bdf9 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -4406,7 +4406,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/xref.el b/lisp/progmodes/xref.el index b0bdd62ae98..5a9a7a925a9 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 diff --git a/lisp/ps-def.el b/lisp/ps-def.el index 9fbb83a74bc..f34473bbb6e 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 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/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 6cee2253746..c28c9b36f05 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 @@ -1387,9 +1387,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 +1441,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 +1547,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 +1615,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 +1672,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 +1708,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 +1730,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 +1742,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 +1777,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 +1820,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 +1915,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 +1926,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) @@ -2180,9 +2220,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 @@ -2212,7 +2252,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 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/server.el b/lisp/server.el index ac0d7018513..a892203c24a 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -251,8 +251,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 +271,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 +628,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 +1077,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 +1092,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 +1245,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 +1279,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 +1288,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 +1298,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 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/simple.el b/lisp/simple.el index b7ad6ebd799..60a00286f89 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,12 @@ 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].") +;; next-error-last-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-last-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 +175,31 @@ 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." + :type '(choice (const :tag "Single next-error capable buffer on selected frame" + next-error-buffer-on-selected-frame) + (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) + avoid-current + 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,18 +216,10 @@ 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))) + ;; 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-last-buffer is an acceptable buffer, use that. (if (and next-error-last-buffer (next-error-buffer-p next-error-last-buffer avoid-current @@ -279,23 +280,50 @@ 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) + (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 + ;; Allow next-error to be used from the next-error capable buffer. + (setq next-error-last-buffer buffer) + (funcall next-error-function (prefix-numeric-value arg) reset) + ;; Override possible change of next-error-last-buffer in next-error-function + (setq next-error-last-buffer buffer) + (setq-default next-error-last-buffer buffer) + (when next-error-recenter + (recenter next-error-recenter)) + (message "%s error from %s" + (cond (reset "First") + ((eq (prefix-numeric-value arg) 0) "Current") + ((< (prefix-numeric-value arg) 0) "Previous") + (t "Next")) + next-error-last-buffer) + (run-hooks 'next-error-hook))))) + +(defun next-error-internal () + "Visit the source code corresponding to the `next-error' message at point." + (let ((buffer (current-buffer))) + ;; We know here that next-error-function is a valid symbol we can funcall + (with-current-buffer buffer + ;; Allow next-error to be used from the next-error capable buffer. + (setq next-error-last-buffer buffer) + (funcall next-error-function 0 nil) + ;; Override possible change of next-error-last-buffer in next-error-function + (setq next-error-last-buffer buffer) + (setq-default next-error-last-buffer buffer) (when next-error-recenter (recenter next-error-recenter)) + (message "Current error from %s" next-error-last-buffer) (run-hooks 'next-error-hook)))) -(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 - (funcall next-error-function 0 nil) - (when next-error-recenter - (recenter next-error-recenter)) - (run-hooks 'next-error-hook))) +(defun next-error-select-buffer (buffer) + "Select a `next-error' capable buffer and set it as the last used." + (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) + (setq-default next-error-last-buffer buffer)) (defalias 'goto-next-locus 'next-error) (defalias 'next-match 'next-error) @@ -3295,6 +3323,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'." @@ -3845,7 +3895,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. @@ -3928,7 +3978,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) @@ -7867,7 +7919,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) @@ -8528,13 +8580,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)) @@ -8959,7 +9014,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) @@ -8969,7 +9024,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/startup.el b/lisp/startup.el index 9d16b59defd..4105c1db2d6 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -123,15 +123,17 @@ 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.") +(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 @@ -781,7 +789,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. @@ -870,6 +878,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." @@ -1021,6 +1115,69 @@ please check its value") (and command-line-args (setcdr command-line-args args))) + ;; 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-initialize)) + ;; 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 @@ -1128,170 +1285,47 @@ please check its value") ;; 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)))) - ;; 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 @@ -1313,33 +1347,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 diff --git a/lisp/subr.el b/lisp/subr.el index 2de5b3766c2..056392a9266 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) @@ -705,21 +705,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. @@ -1438,6 +1446,10 @@ 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") + ;; bug#23850 (make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1") (make-obsolete 'string-as-unibyte "use `encode-coding-string'." "26.1") @@ -1479,10 +1491,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 @@ -1839,15 +1847,13 @@ if it is empty or a duplicate." (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.") @@ -1876,15 +1882,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'. @@ -2573,7 +2586,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. @@ -2596,8 +2609,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 @@ -4528,10 +4541,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 a470873a823..cf7699abc94 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. ;; ;; ---------------------------------------- ;; @@ -392,21 +388,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. @@ -593,9 +582,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'." @@ -753,12 +739,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 @@ -1080,8 +1060,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) @@ -1094,15 +1072,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) @@ -2661,10 +2633,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 @@ -2673,6 +2643,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))) @@ -2705,11 +2680,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. @@ -2762,11 +2732,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) @@ -2774,27 +2739,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)) @@ -2824,298 +2804,214 @@ 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)))) + ;; 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. + (cond ((eq (term-current-column) term-width) + (term-move-columns -1) + (setq term-do-line-wrapping t))) + (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)) + (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)) @@ -3346,87 +3242,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)) )) @@ -3434,15 +3326,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) @@ -3455,8 +3339,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) @@ -3644,7 +3528,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)) @@ -3822,7 +3706,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..1c7dd8a63fe 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) @@ -144,6 +143,7 @@ The properties returned may include `top', `left', `height', and `width'." (define-key global-map [?\s-z] 'undo) (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) @@ -354,7 +354,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 +437,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 () @@ -575,6 +568,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 +738,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 +804,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..fea9851d720 100644 --- a/lisp/term/xterm.el +++ b/lisp/term/xterm.el @@ -68,6 +68,11 @@ 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.") @@ -807,6 +812,8 @@ 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) @@ -833,6 +840,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/bibtex.el b/lisp/textmodes/bibtex.el index a30e1468928..15004ed9c49 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -2932,7 +2932,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. @@ -4925,23 +4925,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..727bc18ebb8 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -32,12 +32,13 @@ ;;; Code: -(require 'eww) (require 'cl-lib) (require 'color) +(require 'eww) (require 'seq) (require 'sgml-mode) (require 'smie) +(require 'thingatpt) (eval-when-compile (require 'subr-x)) (defgroup css nil @@ -808,6 +809,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 +900,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 +940,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 +956,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 +972,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 +1047,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 +1217,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 +1400,122 @@ 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"))) + ;;;###autoload (define-derived-mode css-mode prog-mode "CSS" "Major mode to edit Cascading Style Sheets (CSS). 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/ispell.el b/lisp/textmodes/ispell.el index 9288a77ba3e..512dfcfa6a7 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -1818,11 +1818,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..28c248fb0c4 100644 --- a/lisp/textmodes/mhtml-mode.el +++ b/lisp/textmodes/mhtml-mode.el @@ -364,7 +364,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/page-ext.el b/lisp/textmodes/page-ext.el index 61f02190065..8a41bc37422 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 @@ -415,9 +408,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 +456,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 +507,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 +571,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 +641,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 +694,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 "@e") + (if event (mouse-set-point event)) (if (or (not pages-buffer) (not (buffer-name pages-buffer))) (progn @@ -724,18 +714,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..48c01289347 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) @@ -1344,7 +1323,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) @@ -1541,7 +1519,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 +1535,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 +1973,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 +1981,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 +2403,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 +2639,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 +2653,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 +3127,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 +3600,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 +3614,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 +3628,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 +3644,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 +3658,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 +3672,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 +3685,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 +3699,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 +3713,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 +3795,6 @@ of your own." (const :tag "transitions" t) (const :tag "section title adornment" nil)) :value-type (face))) -(rst-testcover-defcustom) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -4337,7 +4291,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..f6bdfc63844 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -2232,6 +2232,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/texinfo.el b/lisp/textmodes/texinfo.el index c2ceee6e6b7..16399bd9fd7 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -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..76c18b756f7 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) diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el index 1fe0af65ff2..7d0320cb5b1 100644 --- a/lisp/url/url-handlers.el +++ b/lisp/url/url-handlers.el @@ -41,6 +41,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 ;; --------------------- 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/vc/add-log.el b/lisp/vc/add-log.el index cbfd10affd1..175c82f8c00 100644 --- a/lisp/vc/add-log.el +++ b/lisp/vc/add-log.el @@ -1095,7 +1095,7 @@ 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) + (if (and file (file-exists-p file)) (find-file-noselect file) (current-buffer)))) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 7db5ca9b259..ef13f55b931 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)))) @@ -2047,7 +2047,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 +2060,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 +2069,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 +2175,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-wind.el b/lisp/vc/ediff-wind.el index 079e195291d..67e9bf2d9de 100644 --- a/lisp/vc/ediff-wind.el +++ b/lisp/vc/ediff-wind.el @@ -64,10 +64,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 +132,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 +145,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 +212,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 +260,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 +336,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 +354,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 +368,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 +419,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 +438,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 +464,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 +489,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 +508,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 +534,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 +543,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 +568,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 +726,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 +740,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 +759,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 +787,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 +797,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 +810,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 +827,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 +896,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 +958,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 +985,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 +1084,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 +1109,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 +1363,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..a5e8022f1c8 100644 --- a/lisp/vc/ediff.el +++ b/lisp/vc/ediff.el @@ -153,7 +153,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/log-edit.el b/lisp/vc/log-edit.el index 438ef117da6..89b6201bab2 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -623,7 +623,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/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 b439fe736d5..db595331bbd 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..54564678153 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. @@ -1406,6 +1412,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) @@ -1564,7 +1571,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..ad817fd9b9c 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -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) @@ -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..01dc47e8089 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -2420,11 +2420,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/w32-fns.el b/lisp/w32-fns.el index b35e6869d2e..b400c8d4a6f 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 w32-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 w32-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/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..8c5e441e4b6 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -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)) diff --git a/lisp/woman.el b/lisp/woman.el index 533f14674ab..c83a04874a5 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))) 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 |