diff options
Diffstat (limited to 'lisp')
119 files changed, 3373 insertions, 1755 deletions
diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el index 4338181c340..9fa927ddcb3 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 15b7b3a8ac5..9e83a2fb2c8 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 34e1daebb01..71b79223429 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/auth-source-pass.el b/lisp/auth-source-pass.el index 8f69ce323e7..f4f096160ef 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/autoinsert.el b/lisp/autoinsert.el index 2820c8a9afa..a43e068a4dc 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/cedet/ede/detect.el b/lisp/cedet/ede/detect.el index 6240d465982..25426dfeba6 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 51df5e9ffe4..3554ee242b8 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 682ac89978f..cae6e049f44 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 517e1be8eca..b528487887a 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 6ebf130d305..84c60e2dae8 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/lex.el b/lisp/cedet/semantic/lex.el index eec6e6762f3..835888db2ad 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -657,10 +657,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) @@ -810,7 +809,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 53be5e0defb..d5766af9b6e 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/srecode/dictionary.el b/lisp/cedet/srecode/dictionary.el index 4507581621d..6c8fd655d7b 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 10541f61a9e..5b5d1fdd47d 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/cus-edit.el b/lisp/cus-edit.el index a87783850a3..edf3545cadd 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) diff --git a/lisp/delim-col.el b/lisp/delim-col.el index 120131fe034..175bf375162 100644 --- a/lisp/delim-col.el +++ b/lisp/delim-col.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2017 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 c3c9da53b06..5257c609dde 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -1563,8 +1563,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 8fb2c1ff948..3f9912980ba 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1548,6 +1548,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 ask. +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))) @@ -1564,6 +1582,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) @@ -1573,6 +1592,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) diff --git a/lisp/dired.el b/lisp/dired.el index f1a74639a94..0abb521cc5b 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 diff --git a/lisp/electric.el b/lisp/electric.el index d7929945db2..5f4304462dd 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,7 +500,8 @@ 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 + electric-quote-replace-double) (save-excursion (backward-char) (or (bobp) (bolp) @@ -506,13 +519,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/benchmark.el b/lisp/emacs-lisp/benchmark.el index 445e78b427c..02db21a7e53 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 69f03c51668..623985f44f9 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/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 72f82f26f6f..fe6cd4160ed 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/debug.el b/lisp/emacs-lisp/debug.el index e1b87b5c6e2..1ebbc0e0086 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/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index ac8dcc69d21..6293d71470d 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 d00b14e803e..0e8f77e29a8 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1065,6 +1065,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. @@ -1124,47 +1150,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? @@ -1332,7 +1358,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. @@ -1358,9 +1383,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. @@ -2170,7 +2202,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. @@ -2201,7 +2247,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 @@ -2320,22 +2366,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 f11056faecc..58dcd09d7ea 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -467,7 +467,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 75f1097acf1..9276fab0c39 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 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,11 +881,13 @@ 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)) + (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)) @@ -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) @@ -923,14 +936,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/elp.el b/lisp/emacs-lisp/elp.el index 2be9c9da865..905718dad68 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -382,14 +382,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 3a3979e81f0..1d69af80639 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 diff --git a/lisp/emacs-lisp/faceup.el b/lisp/emacs-lisp/faceup.el new file mode 100644 index 00000000000..3a0f7e5c7a5 --- /dev/null +++ b/lisp/emacs-lisp/faceup.el @@ -0,0 +1,1183 @@ +;;; faceup.el --- Markup language for faces and font-lock regression testing -*- lexical-binding: t -*- + +;; Copyright (C) 2013-2017 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: + +(eval-when-compile + (require 'cl)) + + +(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 171) ;; « +(defvar faceup-markup-end-char 187) ;; » + +(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) + "Defines 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/gv.el b/lisp/emacs-lisp/gv.el index 892d6e97167..777b955d90d 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -303,7 +303,9 @@ 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. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 93435e1b4bb..7d38052fd40 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/package.el b/lisp/emacs-lisp/package.el index dd05c70dc8e..68ca1972d1e 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: diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index 691860bbd79..797cc682171 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 bb6d277c270..371d10444b2 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: ;; @@ -44,9 +44,12 @@ ;;; 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) diff --git a/lisp/epa.el b/lisp/epa.el index 6e908e1aa3b..aca9aaa7d22 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -561,7 +561,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.el b/lisp/erc/erc.el index 5fe4f9a80a4..76f4c8b35ab 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2548,9 +2548,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) @@ -2617,7 +2615,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/filecache.el b/lisp/filecache.el index 38a434b11ba..ea7cbcb6f10 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-2017 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/files.el b/lisp/files.el index b47411f206a..e3a34af2dc3 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -4505,8 +4505,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))))) @@ -6407,58 +6407,31 @@ 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." + (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 diff --git a/lisp/format.el b/lisp/format.el index dbb40485c79..8d3dd36fe5b 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/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index daf578180f2..6e7cc57a4cc 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -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)) @@ -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 c130dc1b6c6..97aa878ab63 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -3628,8 +3628,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)))) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index 5ea2d691f15..c57576cf3c7 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -219,7 +219,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 @@ -486,7 +486,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-group.el b/lisp/gnus/gnus-group.el index 996e8266105..89f17316cf1 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -4565,7 +4565,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 6d529558f73..7fa36359f67 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-score.el b/lisp/gnus/gnus-score.el index 11a45dda9ad..bc11aa528fa 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -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)) @@ -2731,8 +2731,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 +3062,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 82056cf1653..8a91973e388 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -452,7 +452,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)) @@ -642,7 +643,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 diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 8c0846be9f7..0b6f72870ee 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-2017 Free Software ;; Foundation, Inc. @@ -29,7 +29,7 @@ (run-hooks 'gnus-load-hook) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'wid-edit) (require 'mm-util) (require 'nnheader) @@ -335,21 +335,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)) @@ -365,25 +350,18 @@ be set in `.emacs' instead." (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") +(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-2-empty '((((class color) (background dark)) - (:foreground "turquoise")) + (:foreground "turquoise4")) (((class color) (background light)) (:foreground "CadetBlue4")) @@ -395,28 +373,21 @@ be set in `.emacs' instead." (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") +(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-3-empty '((((class color) (background dark)) - ()) + (:foreground "turquoise3")) (((class color) (background light)) - ()) + (:foreground "DeepSkyBlue4")) (t ())) "Level 3 empty newsgroup face." @@ -425,28 +396,21 @@ be set in `.emacs' instead." (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") +(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-4-empty '((((class color) (background dark)) - ()) + (:foreground "turquoise2")) (((class color) (background light)) - ()) + (:foreground "DeepSkyBlue3")) (t ())) "Level 4 empty newsgroup face." @@ -455,28 +419,21 @@ be set in `.emacs' instead." (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") +(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-5-empty '((((class color) (background dark)) - ()) + (:foreground "turquoise1")) (((class color) (background light)) - ()) + (:foreground "DeepSkyBlue2")) (t ())) "Level 5 empty newsgroup face." @@ -485,20 +442,13 @@ be set in `.emacs' instead." (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") +(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-6-empty '((((class color) @@ -515,20 +465,13 @@ be set in `.emacs' instead." (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") +(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-low-empty '((((class color) @@ -545,20 +488,13 @@ be set in `.emacs' instead." (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") +(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-mail-1-empty '((((class color) @@ -568,27 +504,20 @@ 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") +(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-2-empty '((((class color) @@ -598,27 +527,20 @@ 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") +(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-3-empty '((((class color) @@ -635,20 +557,13 @@ be set in `.emacs' instead." (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") +(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-low-empty '((((class color) @@ -665,6 +580,14 @@ be set in `.emacs' instead." (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) +;; 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") + ;; Summary mode faces. (defface gnus-summary-selected '((t (:underline t))) @@ -683,15 +606,23 @@ be set in `.emacs' instead." (put 'gnus-summary-cancelled-face 'face-alias 'gnus-summary-cancelled) (put 'gnus-summary-cancelled-face 'obsolete-face "22.1") -(defface gnus-summary-high-ticked +(defface gnus-summary-normal-ticked '((((class color) (background dark)) - (:foreground "pink" :bold t)) + (:foreground "pink")) (((class color) (background light)) - (:foreground "firebrick" :bold t)) + (:foreground "firebrick")) (t - (:bold t))) + ())) + "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-ticked + '((t (:inherit gnus-summary-normal-ticked :bold t))) "Face used for high interest ticked articles." :group 'gnus-summary) ;; backward-compatibility alias @@ -699,44 +630,30 @@ be set in `.emacs' instead." (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))) + '((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-ticked-face 'face-alias 'gnus-summary-low-ticked) (put 'gnus-summary-low-ticked-face 'obsolete-face "22.1") -(defface gnus-summary-normal-ticked +(defface gnus-summary-normal-ancient '((((class color) (background dark)) - (:foreground "pink")) + (:foreground "SkyBlue")) (((class color) (background light)) - (:foreground "firebrick")) + (:foreground "RoyalBlue")) (t ())) - "Face used for normal interest ticked articles." + "Face used for normal interest ancient 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") +(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-ancient - '((((class color) - (background dark)) - (:foreground "SkyBlue" :bold t)) - (((class color) - (background light)) - (:foreground "RoyalBlue" :bold t)) - (t - (:bold t))) + '((t (:inherit gnus-summary-normal-ancient :bold t))) "Face used for high interest ancient articles." :group 'gnus-summary) ;; backward-compatibility alias @@ -744,42 +661,28 @@ be set in `.emacs' instead." (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))) + '((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-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) - (background dark)) - (:foreground "SkyBlue")) - (((class color) - (background light)) - (:foreground "RoyalBlue")) - (t - ())) - "Face used for normal interest ancient articles." +(defface gnus-summary-normal-undownloaded + '((((class color) + (background light)) + (:foreground "cyan4" :bold nil)) + (((class color) (background dark)) + (:foreground "LightGray" :bold nil)) + (t (:inverse-video t))) + "Face used for normal interest uncached 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") +(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-undownloaded - '((((class color) - (background light)) - (:bold t :foreground "cyan4")) - (((class color) (background dark)) - (:bold t :foreground "LightGray")) - (t (:inverse-video t :bold t))) + '((t (:inherit gnus-summary-normal-undownloaded :bold t))) "Face used for high interest uncached articles." :group 'gnus-summary) ;; backward-compatibility alias @@ -787,34 +690,24 @@ be set in `.emacs' instead." (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))) + '((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-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) - (background light)) - (:foreground "cyan4" :bold nil)) - (((class color) (background dark)) - (:foreground "LightGray" :bold nil)) - (t (:inverse-video t))) - "Face used for normal interest uncached articles." +(defface gnus-summary-normal-unread + '((t + ())) + "Face used for normal interest unread 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") +(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-unread - '((t - (:bold t))) + '((t (:inherit gnus-summary-normal-unread :bold t))) "Face used for high interest unread articles." :group 'gnus-summary) ;; backward-compatibility alias @@ -822,34 +715,30 @@ be set in `.emacs' instead." (put 'gnus-summary-high-unread-face 'obsolete-face "22.1") (defface gnus-summary-low-unread - '((t - (:italic t))) + '((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-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 +(defface gnus-summary-normal-read '((((class color) (background dark)) - (:foreground "PaleGreen" - :bold t)) + (:foreground "PaleGreen")) (((class color) (background light)) - (:foreground "DarkGreen" - :bold t)) + (:foreground "DarkGreen")) (t - (:bold t))) + ())) + "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) ;; backward-compatibility alias @@ -857,37 +746,13 @@ be set in `.emacs' instead." (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))) + '((t (:inherit gnus-summary-normal-read :italic t))) "Face used for low interest read 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) - (background dark)) - (:foreground "PaleGreen")) - (((class color) - (background light)) - (:foreground "DarkGreen")) - (t - ())) - "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") - ;;; ;;; Gnus buffers @@ -1106,12 +971,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 +2343,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 +2351,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 +2421,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 +2458,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 +2623,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 @@ -3179,9 +3046,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 +3101,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 +3122,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 +3214,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 +3332,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 +3442,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 +3849,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 +3891,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 +4139,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 +4252,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 690311e36a5..f6777c5e884 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -4390,7 +4390,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) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 2589fa80893..ca4dca4189d 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/nnmail.el b/lisp/gnus/nnmail.el index db5415cf9f7..ad58d292082 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)) diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 272240f5a9f..708a3426af1 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))) diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el index 098ecd5dc3d..3e7428493e4 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/help-fns.el b/lisp/help-fns.el index cae0247a542..3c237654fb9 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -721,6 +721,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/ibuf-ext.el b/lisp/ibuf-ext.el index 686bc392b60..1ef7cb118cc 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 e0c91e20edd..c30067f2f58 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 fed9e75f177..7ed77d29921 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/image/gravatar.el b/lisp/image/gravatar.el index 6628195cfa6..6173c8527eb 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/ldefs-boot.el b/lisp/ldefs-boot.el index 78e1065aae1..ea46f50fc7c 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -8099,12 +8099,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-"))) ;;;*** @@ -8333,7 +8337,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. @@ -8455,7 +8459,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. @@ -12317,6 +12321,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" "\ +Defines 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) @@ -16726,7 +16773,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"))) ;;;*** @@ -30988,7 +31035,7 @@ the sort order. \(fn FIELD BEG END)" t nil) (autoload 'sort-regexp-fields "sort" "\ -Sort the text in the region lexicographically. +Sort the text in the region region lexicographically. If called interactively, prompt for two regular expressions, RECORD-REGEXP and KEY-REGEXP. @@ -32989,10 +33036,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) @@ -33570,7 +33615,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"))) ;;;*** @@ -34397,6 +34442,20 @@ If it is set to nil, all remote file names are used literally.") (custom-autoload 'tramp-mode "tramp" t) +(defvar tramp-syntax 'default "\ +Tramp filename syntax to be used. + +It can have the following values: + + `default' -- Default syntax + `simplified' -- Ange-FTP like syntax + `separate' -- Syntax as defined for XEmacs originally + +Do not change the value by `setq', it must be changed only by +`custom-set-variables'. See also `tramp-change-syntax'.") + +(custom-autoload 'tramp-syntax "tramp" nil) + (defconst tramp-initial-file-name-regexp "\\`/.+:.*:" "\ Value for `tramp-file-name-regexp' for autoload. It must match the initial `tramp-syntax' settings.") @@ -34407,17 +34466,33 @@ This regexp should match Tramp file names but no other file names. When calling `tramp-register-file-name-handlers', the initial value is overwritten by the car of `tramp-file-name-structure'.") -(defconst tramp-autoload-file-name-regexp (concat "\\`/" (if (memq system-type '(cygwin windows-nt)) "\\(-\\|[^/|:]\\{2,\\}\\)" "[^/|:]+") ":\\'") "\ -Regular expression matching file names handled by Tramp autoload. -It must match the initial `tramp-syntax' settings. It should not -match file names at root of the underlying local file system, -like \"/sys\" or \"/C:\".") +(defconst tramp-completion-file-name-regexp-default (concat "\\`/\\(" "\\([^/|:]+:[^/|:]*|\\)*" (if (memq system-type '(cygwin windows-nt)) "\\(-\\|[^/|:]\\{2,\\}\\)" "[^/|:]+") "\\(:[^/|:]*\\)?" "\\)?\\'") "\ +Value for `tramp-completion-file-name-regexp' for default remoting. +See `tramp-file-name-structure' for more explanations. + +On W32 systems, the volume letter must be ignored.") + +(defconst tramp-initial-completion-file-name-regexp tramp-completion-file-name-regexp-default "\ +Value for `tramp-completion-file-name-regexp' for autoload. +It must match the initial `tramp-syntax' settings.") + +(defconst tramp-completion-file-name-handler-alist '((file-name-all-completions . tramp-completion-handle-file-name-all-completions) (file-name-completion . tramp-completion-handle-file-name-completion)) "\ +Alist of completion handler functions. +Used for file names matching `tramp-completion-file-name-regexp'. +Operations not mentioned here will be handled by Tramp's file +name handler functions, or the normal Emacs functions.") + +(autoload 'tramp-completion-file-name-handler "tramp" "\ +Invoke Tramp file name completion handler. +Falls back to normal file name handler if no Tramp file name handler exists. + +\(fn OPERATION &rest ARGS)" nil nil) (defun tramp-autoload-file-name-handler (operation &rest args) "\ Load Tramp file name handler, and perform OPERATION." (let ((default-directory temporary-file-directory)) (load "tramp" (quote noerror) (quote nomessage))) (apply operation args)) (defun tramp-register-autoload-file-name-handlers nil "\ -Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list (quote file-name-handler-alist) (cons tramp-autoload-file-name-regexp (quote tramp-autoload-file-name-handler))) (put (quote tramp-autoload-file-name-handler) (quote safe-magic) t)) +Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list (quote file-name-handler-alist) (cons tramp-initial-file-name-regexp (quote tramp-autoload-file-name-handler))) (put (quote tramp-autoload-file-name-handler) (quote safe-magic) t) (add-to-list (quote file-name-handler-alist) (cons tramp-initial-completion-file-name-regexp (quote tramp-completion-file-name-handler))) (put (quote tramp-completion-file-name-handler) (quote safe-magic) t) (put (quote tramp-completion-file-name-handler) (quote operations) (mapcar (quote car) tramp-completion-file-name-handler-alist))) (tramp-register-autoload-file-name-handlers) @@ -34509,7 +34584,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 3 3 -1)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trampver" '("tramp-"))) @@ -35978,7 +36053,7 @@ When called interactively with a prefix argument, prompt for LIMIT. \(fn &optional LIMIT)" t nil) (autoload 'vc-print-branch-log "vc" "\ -Show the change log for BRANCH in a window. + \(fn BRANCH)" t nil) @@ -38582,44 +38657,53 @@ Zone out, completely. ;;;;;; "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" -;;;;;; "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" +;;;;;; "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" "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/minibuffer.el b/lisp/minibuffer.el index a4a8f5cb282..3b1d6f447a5 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1319,7 +1319,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 () @@ -2986,6 +2986,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 +3028,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 +3037,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/mpc.el b/lisp/mpc.el index c23d8ced716..98f4a031834 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/newst-backend.el b/lisp/net/newst-backend.el index d1ce0e2af73..0b3881428e2 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-2017 Free Software Foundation, Inc. @@ -599,7 +599,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 @@ -635,9 +635,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!"))) @@ -647,9 +646,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." @@ -705,7 +703,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))))) @@ -726,10 +724,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) @@ -1251,9 +1249,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 @@ -1289,7 +1284,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) @@ -1304,9 +1299,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 @@ -1342,7 +1334,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) @@ -1401,7 +1393,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) @@ -1482,7 +1474,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 @@ -1518,89 +1509,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 @@ -1755,12 +1746,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 @@ -1771,22 +1761,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)) @@ -1807,7 +1794,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" @@ -1849,7 +1836,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)) @@ -1910,21 +1897,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") @@ -2004,7 +1991,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) @@ -2016,7 +2003,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 @@ -2289,9 +2276,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." @@ -2358,14 +2344,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) @@ -2405,28 +2390,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." @@ -2499,7 +2482,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/tramp-cmds.el b/lisp/net/tramp-cmds.el index 78ef1a3ef40..37a6521680b 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." diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 3d5dcbdbb14..15868bd2e8f 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -670,8 +670,8 @@ It can have the following values: `simplified' -- Ange-FTP like syntax `separate' -- Syntax as defined for XEmacs originally -Do not change the value by `setq', it must be changed only by -`custom-set-variables'. See also `tramp-change-syntax'." +Do not change the value by `setq', it must be changed only via +Customize. See also `tramp-change-syntax'." :group 'tramp :version "26.1" :package-version '(Tramp . "2.3.3") diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 318e3351237..51af455e635 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.3.3-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.3.3-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -55,7 +55,7 @@ ;; Check for Emacs version. (let ((x (if (>= emacs-major-version 24) "ok" - (format "Tramp 2.3.3.26.1 is not fit for %s" + (format "Tramp 2.3.3-pre is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version))))))) (unless (string-match "\\`ok\\'" x) (error "%s" x))) diff --git a/lisp/newcomment.el b/lisp/newcomment.el index 66296b81828..56ae14dee41 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/rng-maint.el b/lisp/nxml/rng-maint.el index 85614822be8..8d85f2ea06b 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/org/org-agenda.el b/lisp/org/org-agenda.el index cf7a4dbf38b..49519471b38 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -10153,7 +10153,7 @@ to override `appt-message-warning-time'." ;; time and without date as argument, so it may pass wrong ;; information otherwise (today (org-date-to-gregorian - (time-to-days (current-time)))) + (time-to-days nil))) (org-agenda-restrict nil) (files (org-agenda-files 'unrestricted)) entries file (org-agenda-buffer nil)) diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el index 69e199ea27f..fd99c175013 100644 --- a/lisp/org/org-clock.el +++ b/lisp/org/org-clock.el @@ -950,7 +950,7 @@ If necessary, clock-out of the currently active clock." (unless (org-is-active-clock clock) (org-clock-clock-in clock t)))) - ((not (time-less-p resolve-to (current-time))) + ((not (time-less-p resolve-to nil)) (error "RESOLVE-TO must refer to a time in the past")) (t @@ -1052,7 +1052,7 @@ to be CLOCKED OUT.")))) (and (not (memq char-pressed '(?i ?q))) char-pressed))))) (default (floor (/ (float-time - (time-subtract (current-time) last-valid)) 60))) + (time-subtract nil last-valid)) 60))) (keep (and (memq ch '(?k ?K)) (read-number "Keep how many minutes? " default))) @@ -1089,8 +1089,7 @@ to be CLOCKED OUT.")))) (keep (time-add last-valid (seconds-to-time (* 60 keep)))) (gotback - (time-subtract (current-time) - (seconds-to-time (* 60 gotback)))) + (time-subtract nil (seconds-to-time (* 60 gotback)))) (t (error "Unexpected, please report this as a bug"))) (and gotback last-valid) @@ -1172,7 +1171,7 @@ so long." org-clock-marker (marker-buffer org-clock-marker)) (let* ((org-clock-user-idle-seconds (org-user-idle-seconds)) (org-clock-user-idle-start - (time-subtract (current-time) + (time-subtract nil (seconds-to-time org-clock-user-idle-seconds))) (org-clock-resolving-clocks-due-to-idleness t)) (if (> org-clock-user-idle-seconds (* 60 org-clock-idle-time)) @@ -1182,8 +1181,7 @@ so long." (lambda (_) (format "Clocked in & idle for %.1f mins" (/ (float-time - (time-subtract (current-time) - org-clock-user-idle-start)) + (time-subtract nil org-clock-user-idle-start)) 60.0))) org-clock-user-idle-start))))) diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el index eac29c50f65..80f4929b95c 100644 --- a/lisp/org/org-colview.el +++ b/lisp/org/org-colview.el @@ -540,7 +540,7 @@ Where possible, use the standard interface for changing this line." (eol (line-end-position)) (pom (or (get-text-property bol 'org-hd-marker) (point))) (key (or key (get-char-property (point) 'org-columns-key))) - (org-columns--time (float-time (current-time))) + (org-columns--time (float-time)) (action (pcase key ("CLOCKSUM" @@ -790,7 +790,7 @@ When COLUMNS-FMT-STRING is non-nil, use it as the column format." (org-columns-goto-top-level) ;; Initialize `org-columns-current-fmt' and ;; `org-columns-current-fmt-compiled'. - (let ((org-columns--time (float-time (current-time)))) + (let ((org-columns--time (float-time))) (org-columns-get-format columns-fmt-string) (unless org-columns-inhibit-recalculation (org-columns-compute-all)) (save-excursion @@ -1182,7 +1182,7 @@ column specification." "Compute all columns that have operators defined." (org-with-silent-modifications (remove-text-properties (point-min) (point-max) '(org-summaries t))) - (let ((org-columns--time (float-time (current-time))) + (let ((org-columns--time (float-time)) seen) (dolist (spec org-columns-current-fmt-compiled) (let ((property (car spec))) @@ -1494,7 +1494,7 @@ PARAMS is a property list of parameters: (if (markerp org-columns-begin-marker) (move-marker org-columns-begin-marker (point)) (setq org-columns-begin-marker (point-marker))) - (let* ((org-columns--time (float-time (current-time))) + (let* ((org-columns--time (float-time)) (fmt (cond ((bound-and-true-p org-agenda-overriding-columns-format)) diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el index f2b3002f1fd..73012cd2681 100644 --- a/lisp/org/org-element.el +++ b/lisp/org/org-element.el @@ -5067,7 +5067,7 @@ Assume ELEMENT belongs to cache and that a cache is active." TIME-LIMIT is a time value or nil." (and time-limit (or (input-pending-p) - (time-less-p time-limit (current-time))))) + (time-less-p time-limit nil)))) (defsubst org-element--cache-shift-positions (element offset &optional props) "Shift ELEMENT properties relative to buffer positions by OFFSET. @@ -5121,7 +5121,7 @@ updated before current modification are actually submitted." (and next (aref next 0)) threshold (and (not threshold) - (time-add (current-time) + (time-add nil org-element-cache-sync-duration)) future-change) ;; Request processed. Merge current and next offsets and diff --git a/lisp/org/org-habit.el b/lisp/org/org-habit.el index 89b75e6f680..c867c840b0e 100644 --- a/lisp/org/org-habit.el +++ b/lisp/org/org-habit.el @@ -288,7 +288,7 @@ Habits are assigned colors on the following basis: (deadline (if scheduled-days (+ scheduled-days (- d-repeat s-repeat)) (org-habit-deadline habit))) - (m-days (or now-days (time-to-days (current-time))))) + (m-days (or now-days (time-to-days nil)))) (cond ((< m-days scheduled) '(org-habit-clear-face . org-habit-clear-future-face)) @@ -406,7 +406,7 @@ current time." "Insert consistency graph for any habitual tasks." (let ((inhibit-read-only t) (buffer-invisibility-spec '(org-link)) - (moment (time-subtract (current-time) + (moment (time-subtract nil (list 0 (* 3600 org-extend-today-until) 0)))) (save-excursion (goto-char (if line (point-at-bol) (point-min))) diff --git a/lisp/org/org-indent.el b/lisp/org/org-indent.el index b34586e09ec..35c1f22719e 100644 --- a/lisp/org/org-indent.el +++ b/lisp/org/org-indent.el @@ -325,7 +325,7 @@ stopped." (let* ((case-fold-search t) (limited-re (org-get-limited-outline-regexp)) (level (or (org-current-level) 0)) - (time-limit (and delay (time-add (current-time) delay)))) + (time-limit (and delay (time-add nil delay)))) ;; For each line, set `line-prefix' and `wrap-prefix' ;; properties depending on the type of line (headline, inline ;; task, item or other). @@ -338,7 +338,7 @@ stopped." ;; In asynchronous mode, take a break of ;; `org-indent-agent-resume-delay' every DELAY to avoid ;; blocking any other idle timer or process output. - ((and delay (time-less-p time-limit (current-time))) + ((and delay (time-less-p time-limit nil)) (setq org-indent-agent-resume-timer (run-with-idle-timer (time-add (current-idle-time) org-indent-agent-resume-delay) diff --git a/lisp/org/org-timer.el b/lisp/org/org-timer.el index 5acf526f183..7617a3810f9 100644 --- a/lisp/org/org-timer.el +++ b/lisp/org/org-timer.el @@ -144,7 +144,7 @@ the region 0:00:00." ;; Pass `current-time' result to `float-time' (instead ;; of calling without arguments) so that only ;; `current-time' has to be overridden in tests. - (- (float-time (current-time)) delta)))) + (- (float-time) delta)))) (setq org-timer-pause-time nil) (org-timer-set-mode-line 'on) (message "Timer start time set to %s, current value is %s" @@ -168,12 +168,12 @@ With prefix arg STOP, stop it entirely." (org-timer--run-countdown-timer new-secs org-timer-countdown-timer-title)) (setq org-timer-start-time - (time-add (current-time) (seconds-to-time new-secs)))) + (time-add nil (seconds-to-time new-secs)))) (setq org-timer-start-time ;; Pass `current-time' result to `float-time' (instead ;; of calling without arguments) so that only ;; `current-time' has to be overridden in tests. - (seconds-to-time (- (float-time (current-time)) + (seconds-to-time (- (float-time) (- pause-secs start-secs))))) (setq org-timer-pause-time nil) (org-timer-set-mode-line 'on) @@ -238,8 +238,8 @@ it in the buffer." ;; overridden in tests. (if org-timer-countdown-timer (- (float-time org-timer-start-time) - (float-time (or org-timer-pause-time (current-time)))) - (- (float-time (or org-timer-pause-time (current-time))) + (float-time org-timer-pause-time)) + (- (float-time org-timer-pause-time) (float-time org-timer-start-time)))) ;;;###autoload @@ -400,7 +400,7 @@ VALUE can be `on', `off', or `paused'." (message "No timer set") (let* ((rtime (decode-time (time-subtract (timer--time org-timer-countdown-timer) - (current-time)))) + nil))) (rsecs (nth 0 rtime)) (rmins (nth 1 rtime))) (message "%d minute(s) %d seconds left before next time out" @@ -464,7 +464,7 @@ using three `C-u' prefix arguments." secs org-timer-countdown-timer-title)) (run-hooks 'org-timer-set-hook) (setq org-timer-start-time - (time-add (current-time) (seconds-to-time secs))) + (time-add nil (seconds-to-time secs))) (setq org-timer-pause-time nil) (org-timer-set-mode-line 'on)))))) diff --git a/lisp/org/org.el b/lisp/org/org.el index 35405b4bf81..569bc9f8ec1 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -227,7 +227,7 @@ file to byte-code before it is loaded." (interactive "fFile to load: \nP") (let* ((age (lambda (file) (float-time - (time-subtract (current-time) + (time-subtract nil (nth 5 (or (file-attributes (file-truename file)) (file-attributes file))))))) (base-name (file-name-sans-extension file)) @@ -5597,15 +5597,14 @@ the rounding returns a past time." (apply 'encode-time (append (list 0 (* r (floor (+ .5 (/ (float (nth 1 time)) r))))) (nthcdr 2 time)))) - (if (and past (< (float-time (time-subtract (current-time) res)) 0)) + (if (and past (< (float-time (time-subtract nil res)) 0)) (seconds-to-time (- (float-time res) (* r 60))) res)))) (defun org-today () "Return today date, considering `org-extend-today-until'." (time-to-days - (time-subtract (current-time) - (list 0 (* 3600 org-extend-today-until) 0)))) + (time-subtract nil (list 0 (* 3600 org-extend-today-until) 0)))) ;;;; Font-Lock stuff, including the activators @@ -13057,8 +13056,7 @@ This function is run automatically after each state change to a DONE state." (while (re-search-forward org-clock-line-re end t) (when (org-at-clock-log-p) (throw :clock t)))))) (org-entry-put nil "LAST_REPEAT" (format-time-string - (org-time-stamp-format t t) - (current-time)))) + (org-time-stamp-format t t)))) (when org-log-repeat (if (or (memq 'org-add-log-note (default-value 'post-command-hook)) (memq 'org-add-log-note post-command-hook)) @@ -13117,7 +13115,7 @@ has been set" (let ((nshiftmax 10) (nshift 0)) (while (or (= nshift 0) - (not (time-less-p (current-time) time))) + (not (time-less-p nil time))) (when (= (cl-incf nshift) nshiftmax) (or (y-or-n-p (format "%d repeater intervals were not \ @@ -16904,7 +16902,7 @@ user." ;; overridden in tests. (let ((org-def def) (org-defdecode defdecode) - (nowdecode (decode-time (current-time))) + (nowdecode (decode-time)) delta deltan deltaw deltadef year month day hour minute second wday pm h2 m2 tl wday1 iso-year iso-weekday iso-week iso-date futurep kill-year) @@ -17070,7 +17068,7 @@ user." ; (when (and org-read-date-prefer-future ; (not iso-year) ; (< (calendar-absolute-from-gregorian iso-date) - ; (time-to-days (current-time)))) + ; (time-to-days nil))) ; (setq year (1+ year) ; iso-date (calendar-gregorian-from-absolute ; (calendar-iso-to-absolute @@ -17084,7 +17082,7 @@ user." ;; Pass `current-time' result to `decode-time' (instead of ;; calling without arguments) so that only `current-time' has ;; to be overridden in tests. - (let ((now (decode-time (current-time)))) + (let ((now (decode-time))) (setq day (nth 3 now) month (nth 4 now) year (nth 5 now)))) (cond ((member deltaw '("d" "")) (setq day (+ day deltan))) ((equal deltaw "w") (setq day (+ day (* 7 deltan)))) @@ -17564,7 +17562,7 @@ signaled." YEAR is expanded into one of the 30 next years, if possible, or into a past one. Any year larger than 99 is returned unchanged." (if (>= year 100) year - (let* ((current (string-to-number (format-time-string "%Y" (current-time)))) + (let* ((current (string-to-number (format-time-string "%Y"))) (century (/ current 100)) (offset (- year (% current 100)))) (cond ((> offset 30) (+ (* (1- century) 100) year)) @@ -18088,7 +18086,7 @@ A prefix ARG can be used to force the current date." diff) (when (or (org-at-timestamp-p 'lax) (org-match-line (concat ".*" org-ts-regexp))) - (let ((d1 (time-to-days (current-time))) + (let ((d1 (time-to-days nil)) (d2 (time-to-days (org-time-string-to-time (match-string 1))))) (setq diff (- d2 d1)))) (calendar) diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 1c43577cddf..820b1755624 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -3243,7 +3243,7 @@ locally for the subtree through node properties." (let ((val (cond ((equal (car key) "DATE") (or (cdr key) (with-temp-buffer - (org-insert-time-stamp (current-time))))) + (org-insert-time-stamp nil)))) ((equal (car key) "TITLE") (or (let ((visited-file (buffer-file-name (buffer-base-buffer)))) diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index 6214e07506d..6223a01d4fa 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-2017 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 328cbe01e4f..acfea5e9887 100644 --- a/lisp/printing.el +++ b/lisp/printing.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2000-2001, 2003-2017 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/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 4c63ec2fb4e..e6ab8c4ea60 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -2316,7 +2316,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" diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el index 8aaebdde5bc..f49c8e934a5 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 f73efe45399..937f9881ce9 100644 --- a/lisp/progmodes/ebnf-abn.el +++ b/lisp/progmodes/ebnf-abn.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2001-2017 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 7d426f9491c..9cad4e5f2b6 100644 --- a/lisp/progmodes/ebnf-bnf.el +++ b/lisp/progmodes/ebnf-bnf.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2017 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 545e2107c2b..ee9f7b14e9b 100644 --- a/lisp/progmodes/ebnf-dtd.el +++ b/lisp/progmodes/ebnf-dtd.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2001-2017 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 048a0a198ed..6d1e761a1a5 100644 --- a/lisp/progmodes/ebnf-ebx.el +++ b/lisp/progmodes/ebnf-ebx.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2001-2017 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 c50bcb87d98..61a3479a5c3 100644 --- a/lisp/progmodes/ebnf-iso.el +++ b/lisp/progmodes/ebnf-iso.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2017 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 7d5d0d641d7..f77959e4ca2 100644 --- a/lisp/progmodes/ebnf-otz.el +++ b/lisp/progmodes/ebnf-otz.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2017 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 d7b20708768..d8916ee4c0d 100644 --- a/lisp/progmodes/ebnf-yac.el +++ b/lisp/progmodes/ebnf-yac.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2017 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 a813d42356c..5c9a106d41a 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-2017 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/flymake-proc.el b/lisp/progmodes/flymake-proc.el index 2e98b2afd1e..e28451d9417 100644 --- a/lisp/progmodes/flymake-proc.el +++ b/lisp/progmodes/flymake-proc.el @@ -41,6 +41,8 @@ ;;; Code: +(require 'cl-lib) + (require 'flymake) (defcustom flymake-proc-compilation-prevents-syntax-check t @@ -65,6 +67,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") + (defcustom flymake-proc-allowed-file-name-masks '(("\\.\\(?:c\\(?:pp\\|xx\\|\\+\\+\\)?\\|CC\\)\\'" flymake-proc-simple-make-init @@ -91,6 +100,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. @@ -188,17 +198,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 b4ab7f223f2..1930f4fc832 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -409,6 +409,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/idlwave.el b/lisp/progmodes/idlwave.el index 9231e118907..92a42b1cb94 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/ps-def.el b/lisp/ps-def.el index ea77b6ba53b..a23ca53a831 100644 --- a/lisp/ps-def.el +++ b/lisp/ps-def.el @@ -2,10 +2,10 @@ ;; Copyright (C) 2007-2017 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 393de9ff7a7..0d850f1e520 100644 --- a/lisp/ps-mule.el +++ b/lisp/ps-mule.el @@ -2,10 +2,10 @@ ;; Copyright (C) 1998-2017 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 b50363812e3..8571f2287ac 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. diff --git a/lisp/ps-samp.el b/lisp/ps-samp.el index 15f5c7c814f..7507eee8f64 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 913380763c6..23eefd08b88 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -182,8 +182,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 diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el index 3d27858d0fe..cac91e421e0 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/archive/html/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/simple.el b/lisp/simple.el index 4db81071b58..e09ddd2e689 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -279,23 +279,28 @@ To control which errors are matched, customize the variable `compilation-error-regexp-alist'." (interactive "P") (if (consp arg) (setq reset t arg nil)) - (when (setq next-error-last-buffer (next-error-find-buffer)) - ;; we know here that next-error-function is a valid symbol we can funcall - (with-current-buffer next-error-last-buffer - (funcall next-error-function (prefix-numeric-value arg) reset) - (when next-error-recenter - (recenter next-error-recenter)) - (run-hooks 'next-error-hook)))) + (let ((buffer (next-error-find-buffer))) + (when buffer + ;; We know here that next-error-function is a valid symbol we can funcall + (with-current-buffer buffer + (funcall next-error-function (prefix-numeric-value arg) reset) + ;; Override possible change of next-error-last-buffer in next-error-function + (setq next-error-last-buffer buffer) + (when next-error-recenter + (recenter next-error-recenter)) + (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))) + (let ((buffer (current-buffer))) + ;; We know here that next-error-function is a valid symbol we can funcall + (with-current-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) + (when next-error-recenter + (recenter next-error-recenter)) + (run-hooks 'next-error-hook)))) (defalias 'goto-next-locus 'next-error) (defalias 'next-match 'next-error) diff --git a/lisp/subr.el b/lisp/subr.el index a955b8131d6..1f68c25c888 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) diff --git a/lisp/svg.el b/lisp/svg.el index 6a0c49b4698..ae7f1c57c02 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/term/xterm.el b/lisp/term/xterm.el index 4f79703833d..b7d0cfb4792 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.") @@ -802,6 +807,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) @@ -828,6 +835,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/css-mode.el b/lisp/textmodes/css-mode.el index 1de4ff0fca9..93ca36b08aa 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -896,7 +896,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 "\\)\\|" diff --git a/lisp/textmodes/page-ext.el b/lisp/textmodes/page-ext.el index 94b68decfb7..bf1e33bf0f6 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-2017 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 ec41dee14e8..8d69d8feda5 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 730eaecc71c..7300af06f49 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 315059e1107..393b679e4a1 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/thingatpt.el b/lisp/thingatpt.el index 485cc97555f..e3a4d4d7c1e 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 c8726a9a1b0..6cd7320e72f 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -583,7 +583,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 18ddd25703c..44b6938a6fd 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 faf44b3b875..35b0efe65b1 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-cache.el b/lisp/url/url-cache.el index 1cffc06d7c3..963dfd531e2 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 d922033d820..109d55ad39d 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.el b/lisp/url/url.el index 9a6b732ca9c..36cd81bd70b 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/ediff-wind.el b/lisp/vc/ediff-wind.el index 138cfdd2e70..79ccc6d32db 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/vc-git.el b/lisp/vc/vc-git.el index ed85603f828..f95e67f4f56 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -857,13 +857,13 @@ 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)) -(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)) @@ -882,6 +882,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 @@ -889,7 +890,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'. @@ -904,13 +905,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. diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 99c8869ae06..9e597a209a7 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1296,12 +1296,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 +1305,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 +1324,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 +1340,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 +1371,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 +1389,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/whitespace.el b/lisp/whitespace.el index cd04e6651ac..32a90ba485b 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2000-2017 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/xdg.el b/lisp/xdg.el index e73e6199d6f..9edc3d2629c 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 |