procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge remote-tracking branch 'origin/master' into feature/android

Browse source
This commit is contained in:
Po Lu 2023-04-10 08:16:44 +08:00
commit 857e2bcb66
19 changed files with 264 additions and 154 deletions
Download patch file Download diff file Expand all files Collapse all files

15
etc/NEWS
View file

@ -480,6 +480,21 @@ simplified away.
This warning can be suppressed using 'with-suppressed-warnings' with This warning can be suppressed using 'with-suppressed-warnings' with
the warning name 'suspicious'. the warning name 'suspicious'.
---
*** Warn about more ignored function return values.
The compiler now warns when the return value from certain functions is
ignored. Example:
(progn (nreverse my-list) my-list)
will elicit a warning because it is usually pointless to call
'nreverse' on a list without using the returned value. To silence the
warning, make use of the value in some way, such as assigning it to a
variable. You can also wrap the function call in '(ignore ...)'.
This warning can be suppressed using 'with-suppressed-warnings' with
the warning name 'ignored-return-value'.
+++ +++
** New function 'file-user-uid'. ** New function 'file-user-uid'.
This function is like 'user-uid', but is aware of file name handlers, This function is like 'user-uid', but is aware of file name handlers,

2
lisp/emacs-lisp/byte-opt.el
View file

@ -1706,7 +1706,7 @@ See Info node `(elisp) Integer Basics'."
charsetp commandp cons consp charsetp commandp cons consp
current-buffer current-global-map current-indentation current-buffer current-global-map current-indentation
current-local-map current-minor-mode-maps current-time current-local-map current-minor-mode-maps current-time
eobp eolp eq equal eobp eolp eq equal eql
floatp following-char framep floatp following-char framep
hash-table-p hash-table-p
identity indirect-function integerp integer-or-marker-p identity indirect-function integerp integer-or-marker-p

62
lisp/emacs-lisp/bytecomp.el
View file

@ -3502,7 +3502,67 @@ lambda-expression."
;; so maybe we don't need to bother about it here? ;; so maybe we don't need to bother about it here?
(setq form (cons 'progn (cdr form))) (setq form (cons 'progn (cdr form)))
(setq handler #'byte-compile-progn)) (setq handler #'byte-compile-progn))
((and (or sef (eq (car form) 'mapcar)) ((and (or sef
(memq (car form)
;; FIXME: Use a function property (declaration)
;; instead of this list.
'(
;; Functions that are side-effect-free
;; except for the behaviour of
;; functions passed as argument.
mapcar mapcan mapconcat
cl-mapcar cl-mapcan cl-maplist cl-map cl-mapcon
cl-reduce
assoc assoc-default plist-get plist-member
cl-assoc cl-assoc-if cl-assoc-if-not
cl-rassoc cl-rassoc-if cl-rassoc-if-not
cl-member cl-member-if cl-member-if-not
cl-adjoin
cl-mismatch cl-search
cl-find cl-find-if cl-find-if-not
cl-position cl-position-if cl-position-if-not
cl-count cl-count-if cl-count-if-not
cl-remove cl-remove-if cl-remove-if-not
cl-member cl-member-if cl-member-if-not
cl-remove-duplicates
cl-subst cl-subst-if cl-subst-if-not
cl-substitute cl-substitute-if
cl-substitute-if-not
cl-sublis
cl-union cl-intersection
cl-set-difference cl-set-exclusive-or
cl-subsetp
cl-every cl-some cl-notevery cl-notany
cl-tree-equal
;; Functions that mutate and return a list.
cl-delete-if cl-delete-if-not
;; `delete-dups' and `delete-consecutive-dups'
;; never delete the first element so it's
;; safe to ignore their return value, but
;; this isn't the case with
;; `cl-delete-duplicates'.
cl-delete-duplicates
cl-nsubst cl-nsubst-if cl-nsubst-if-not
cl-nsubstitute cl-nsubstitute-if
cl-nsubstitute-if-not
cl-nunion cl-nintersection
cl-nset-difference cl-nset-exclusive-or
cl-nreconc cl-nsublis
cl-merge
;; It's safe to ignore the value of `sort'
;; and `nreverse' when used on arrays,
;; but most calls pass lists.
nreverse
sort cl-sort cl-stable-sort
;; Adding the following functions yields many
;; positives; evaluate how many of them are
;; false first.
;;delq delete cl-delete
;;nconc plist-put
)))
(byte-compile-warning-enabled-p (byte-compile-warning-enabled-p
'ignored-return-value (car form))) 'ignored-return-value (car form)))
(byte-compile-warn-x (byte-compile-warn-x

2
lisp/emacs-lisp/cl-extra.el
View file

@ -408,6 +408,7 @@ Other non-digit chars are considered junk.
RADIX is an integer between 2 and 36, the default is 10. Signal RADIX is an integer between 2 and 36, the default is 10. Signal
an error if the substring between START and END cannot be parsed an error if the substring between START and END cannot be parsed
as an integer unless JUNK-ALLOWED is non-nil." as an integer unless JUNK-ALLOWED is non-nil."
(declare (side-effect-free t))
(cl-check-type string string) (cl-check-type string string)
(let* ((start (or start 0)) (let* ((start (or start 0))
(len (length string)) (len (length string))
@ -566,6 +567,7 @@ too large if positive or too small if negative)."
;;;###autoload ;;;###autoload
(defun cl-revappend (x y) (defun cl-revappend (x y)
"Equivalent to (append (reverse X) Y)." "Equivalent to (append (reverse X) Y)."
(declare (side-effect-free t))
(nconc (reverse x) y)) (nconc (reverse x) y))
;;;###autoload ;;;###autoload

1
lisp/emacs-lisp/cl-lib.el
View file

@ -459,6 +459,7 @@ Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
(defun cl-copy-list (list) (defun cl-copy-list (list)
"Return a copy of LIST, which may be a dotted list. "Return a copy of LIST, which may be a dotted list.
The elements of LIST are not copied, just the list structure itself." The elements of LIST are not copied, just the list structure itself."
(declare (side-effect-free error-free))
(if (consp list) (if (consp list)
(let ((res nil)) (let ((res nil))
(while (consp list) (push (pop list) res)) (while (consp list) (push (pop list) res))

6
lisp/emacs-lisp/cl-macs.el
View file

@ -3690,14 +3690,14 @@ macro that returns its `&whole' argument."
;;; Things that are side-effect-free. ;;; Things that are side-effect-free.
(mapc (lambda (x) (function-put x 'side-effect-free t)) (mapc (lambda (x) (function-put x 'side-effect-free t))
'(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd '(cl-oddp cl-evenp cl-signum cl-ldiff cl-pairlis cl-gcd
cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem
cl-subseq cl-list-length cl-get cl-getf)) cl-subseq cl-list-length cl-get cl-getf))
;;; Things that are side-effect-and-error-free. ;;; Things that are side-effect-and-error-free.
(mapc (lambda (x) (function-put x 'side-effect-free 'error-free)) (mapc (lambda (x) (function-put x 'side-effect-free 'error-free))
'(eql cl-list* cl-subst cl-acons cl-equalp '(cl-list* cl-acons cl-equalp
cl-random-state-p copy-tree cl-sublis)) cl-random-state-p copy-tree))
;;; Types and assertions. ;;; Types and assertions.

4
lisp/emacs-lisp/ert-x.el
View file

@ -563,9 +563,9 @@ The same keyword arguments are supported as in
;; Emacs's Makefile sets $HOME to a nonexistent value. Needed ;; Emacs's Makefile sets $HOME to a nonexistent value. Needed
;; in batch mode only, therefore. ;; in batch mode only, therefore.
(when (and noninteractive (not (file-directory-p "~/"))) (when (and noninteractive (not (file-directory-p "~/")))
(setenv "HOME" temporary-file-directory)) (setenv "HOME" (directory-file-name temporary-file-directory)))
(format "/mock::%s" temporary-file-directory)))) (format "/mock::%s" temporary-file-directory))))
"Temporary directory for remote file tests.") "Temporary directory for remote file tests.")
(provide 'ert-x) (provide 'ert-x)

3
lisp/gnus/gnus-group.el
View file

@ -4195,7 +4195,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(let ((info (gnus-get-info group)) (let ((info (gnus-get-info group))
(active (gnus-active group))) (active (gnus-active group)))
(when info (when info
(gnus-request-update-info info method)) (gnus-request-update-info info method)
(setq active (gnus-active group)))
(gnus-get-unread-articles-in-group info active) (gnus-get-unread-articles-in-group info active)
(unless (gnus-virtual-group-p group) (unless (gnus-virtual-group-p group)
(gnus-close-group group)) (gnus-close-group group))

3
lisp/gnus/gnus-start.el
View file

@ -1490,7 +1490,8 @@ backend check whether the group actually exists."
(gnus-request-update-info (gnus-request-update-info
info (inline (gnus-find-method-for-group info (inline (gnus-find-method-for-group
(gnus-info-group info))))) (gnus-info-group info)))))
(gnus-activate-group (gnus-info-group info) nil t)) (gnus-activate-group (gnus-info-group info) nil t)
(setq active (gnus-active (gnus-info-group info))))
(let* ((range (gnus-info-read info)) (let* ((range (gnus-info-read info))
(num 0)) (num 0))

143
lisp/gnus/nnselect.el
View file

@ -440,7 +440,7 @@ artlist; otherwise store the ARTLIST in the group parameters."
(if (eq 'nnselect (car (gnus-server-to-method server))) (if (eq 'nnselect (car (gnus-server-to-method server)))
(with-current-buffer gnus-summary-buffer (with-current-buffer gnus-summary-buffer
(let ((thread (gnus-id-to-thread article))) (let ((thread (gnus-id-to-thread article)))
(when thread (when (car thread)
(mapc (mapc
(lambda (x) (lambda (x)
(when (and x (> x 0)) (when (and x (> x 0))
@ -594,62 +594,63 @@ artlist; otherwise store the ARTLIST in the group parameters."
(gnus-newsgroup-selection (gnus-newsgroup-selection
(or gnus-newsgroup-selection (nnselect-get-artlist group))) (or gnus-newsgroup-selection (nnselect-get-artlist group)))
newmarks) newmarks)
(gnus-info-set-marks info nil) (when gnus-newsgroup-selection
(setf (gnus-info-read info) nil) (gnus-info-set-marks info nil)
(pcase-dolist (`(,artgroup . ,nartids) (setf (gnus-info-read info) nil)
(ids-by-group (pcase-dolist (`(,artgroup . ,nartids)
(number-sequence 1 (nnselect-artlist-length (ids-by-group
gnus-newsgroup-selection)))) (number-sequence 1 (nnselect-artlist-length
(let* ((gnus-newsgroup-active nil) gnus-newsgroup-selection))))
(idmap (make-hash-table :test 'eql)) (let* ((gnus-newsgroup-active nil)
(gactive (sort (mapcar 'cdr nartids) '<)) (idmap (make-hash-table :test 'eql))
(group-info (gnus-get-info artgroup)) (gactive (sort (mapcar 'cdr nartids) #'<))
(marks (gnus-info-marks group-info))) (group-info (gnus-get-info artgroup))
(pcase-dolist (`(,val . ,key) nartids) (marks (gnus-info-marks group-info)))
(puthash key val idmap)) (pcase-dolist (`(,val . ,key) nartids)
(setf (gnus-info-read info) (puthash key val idmap))
(range-add-list (setf (gnus-info-read info)
(gnus-info-read info) (range-add-list
(sort (mapcar (lambda (art) (gethash art idmap)) (gnus-info-read info)
(gnus-sorted-intersection (sort (mapcar (lambda (art) (gethash art idmap))
gactive (gnus-sorted-intersection
(range-uncompress (gnus-info-read group-info)))) gactive
'<))) (range-uncompress (gnus-info-read group-info))))
(pcase-dolist (`(,type . ,mark-list) marks) #'<)))
(let ((mark-type (gnus-article-mark-to-type type)) new) (pcase-dolist (`(,type . ,mark-list) marks)
(when (let ((mark-type (gnus-article-mark-to-type type)) new)
(setq new (when
(if (not mark-list) nil (setq new
(cond (if (not mark-list) nil
((eq mark-type 'tuple) (cond
(delq nil ((eq mark-type 'tuple)
(mapcar (delq nil
(lambda (mark) (mapcar
(let ((id (gethash (car mark) idmap))) (lambda (mark)
(when id (cons id (cdr mark))))) (let ((id (gethash (car mark) idmap)))
mark-list))) (when id (cons id (cdr mark)))))
(t mark-list)))
(mapcar (lambda (art) (gethash art idmap)) (t
(gnus-sorted-intersection (mapcar (lambda (art) (gethash art idmap))
gactive (range-uncompress mark-list))))))) (gnus-sorted-intersection
(let ((previous (alist-get type newmarks))) gactive (range-uncompress mark-list)))))))
(if previous (let ((previous (alist-get type newmarks)))
(nconc previous new) (if previous
(push (cons type new) newmarks)))))))) (nconc previous new)
(push (cons type new) newmarks))))))))
;; Clean up the marks: compress lists; ;; Clean up the marks: compress lists;
(pcase-dolist (`(,type . ,mark-list) newmarks) (pcase-dolist (`(,type . ,mark-list) newmarks)
(let ((mark-type (gnus-article-mark-to-type type))) (let ((mark-type (gnus-article-mark-to-type type)))
(unless (eq mark-type 'tuple) (unless (eq mark-type 'tuple)
(setf (alist-get type newmarks) (setf (alist-get type newmarks)
(gnus-compress-sequence (sort mark-list '<)))))) (gnus-compress-sequence (sort mark-list #'<))))))
;; and ensure an unexist key. ;; and ensure an unexist key.
(unless (assq 'unexist newmarks) (unless (assq 'unexist newmarks)
(push (cons 'unexist nil) newmarks)) (push (cons 'unexist nil) newmarks))
(gnus-info-set-marks info newmarks) (gnus-info-set-marks info newmarks)
(gnus-set-active group (cons 1 (nnselect-artlist-length (gnus-set-active group (cons 1 (nnselect-artlist-length
gnus-newsgroup-selection))))) gnus-newsgroup-selection))))))
(deffoo nnselect-request-thread (header &optional group server) (deffoo nnselect-request-thread (header &optional group server)
@ -759,7 +760,8 @@ artlist; otherwise store the ARTLIST in the group parameters."
(deffoo nnselect-close-group (group &optional _server) (deffoo nnselect-close-group (group &optional _server)
(let ((group (nnselect-add-prefix group))) (let ((group (nnselect-add-prefix group)))
(unless gnus-group-is-exiting-without-update-p (unless gnus-group-is-exiting-without-update-p
(nnselect-push-info group)) (when gnus-newsgroup-selection
(nnselect-push-info group)))
(setq gnus-newsgroup-selection nil) (setq gnus-newsgroup-selection nil)
(when (gnus-ephemeral-group-p group) (when (gnus-ephemeral-group-p group)
(gnus-kill-ephemeral-group group) (gnus-kill-ephemeral-group group)
@ -882,23 +884,28 @@ article came from is also searched."
(defun nnselect-push-info (group) (defun nnselect-push-info (_group)
"Copy mark-lists from GROUP to the originating groups." "Copy mark-lists from GROUP to the originating groups."
(let ((select-unreads (numbers-by-group gnus-newsgroup-unreads)) (let ((select-unreads (numbers-by-group gnus-newsgroup-unreads))
(select-reads (numbers-by-group (select-reads (numbers-by-group
(gnus-info-read (gnus-get-info group)) 'range)) (gnus-sorted-difference gnus-newsgroup-articles
(select-unseen (numbers-by-group gnus-newsgroup-unseen)) gnus-newsgroup-unreads)))
(gnus-newsgroup-active nil) mark-list) (select-unseen (numbers-by-group gnus-newsgroup-unseen))
(gnus-newsgroup-active nil) mark-list)
;; collect the set of marked article lists categorized by ;; collect the set of marked article lists categorized by
;; originating groups ;; originating groups
(pcase-dolist (`(,mark . ,type) gnus-article-mark-lists) (pcase-dolist (`(,mark . ,type) gnus-article-mark-lists)
(let (type-list) (let ((mark-type (gnus-article-mark-to-type type))
(when (setq type-list (type-list (symbol-value
(symbol-value (intern (format "gnus-newsgroup-%s" mark)))) (intern (format "gnus-newsgroup-%s" mark)))))
(push (cons (when type-list
type (unless (eq 'tuple mark-type)
(numbers-by-group type-list (gnus-article-mark-to-type type))) (setq type-list (range-list-intersection
mark-list)))) gnus-newsgroup-articles type-list)))
(push (cons
type
(numbers-by-group type-list mark-type))
mark-list))))
;; now work on each originating group one at a time ;; now work on each originating group one at a time
(pcase-dolist (`(,artgroup . ,artlist) (pcase-dolist (`(,artgroup . ,artlist)
(numbers-by-group gnus-newsgroup-articles)) (numbers-by-group gnus-newsgroup-articles))

3
lisp/net/eudcb-mab.el
View file

@ -86,7 +86,8 @@ RETURN-ATTRS is a list of attributes to return, defaulting to
((eq (car term) 'email) ((eq (car term) 'email)
(unless (string= (cdr term) mail) (unless (string= (cdr term) mail)
(setq matched nil))) (setq matched nil)))
((eq (car term) 'phone)))) ;; ((eq (car term) 'phone))
))
(when matched (when matched
(setq result (setq result

4
lisp/net/tramp-sshfs.el
View file

@ -244,8 +244,8 @@ arguments to pass to the OPERATION."
(setq result (setq result
(insert-file-contents (insert-file-contents
(tramp-fuse-local-file-name filename) visit beg end replace)) (tramp-fuse-local-file-name filename) visit beg end replace))
(when visit (setq buffer-file-name filename)) (when visit (setq buffer-file-name filename)))
(cons filename (cdr result))))) (cons filename (cdr result))))
(defun tramp-sshfs-handle-process-file (defun tramp-sshfs-handle-process-file
(program &optional infile destination display &rest args) (program &optional infile destination display &rest args)

3
lisp/org/ob-core.el
View file

@ -2426,7 +2426,8 @@ INFO may provide the values of these header arguments (in the
(delete-region (point) (org-babel-result-end))) (delete-region (point) (org-babel-result-end)))
((member "append" result-params) ((member "append" result-params)
(goto-char (org-babel-result-end)) (setq beg (point-marker))) (goto-char (org-babel-result-end)) (setq beg (point-marker)))
((member "prepend" result-params))) ; already there ;; ((member "prepend" result-params)) ; already there
)
(setq results-switches (setq results-switches
(if results-switches (concat " " results-switches) "")) (if results-switches (concat " " results-switches) ""))
(let ((wrap (let ((wrap

8
lisp/progmodes/project.el
View file

@ -1248,8 +1248,10 @@ If you exit the `query-replace', you can later continue the
(defun project-prefixed-buffer-name (mode) (defun project-prefixed-buffer-name (mode)
(concat "*" (concat "*"
(file-name-nondirectory (if-let ((proj (project-current nil)))
(directory-file-name default-directory)) (project-name proj)
(file-name-nondirectory
(directory-file-name default-directory)))
"-" "-"
(downcase mode) (downcase mode)
"*")) "*"))
@ -1261,7 +1263,7 @@ If non-nil, it overrides `compilation-buffer-name-function' for
:version "28.1" :version "28.1"
:group 'project :group 'project
:type '(choice (const :tag "Default" nil) :type '(choice (const :tag "Default" nil)
(const :tag "Prefixed with root directory name" (const :tag "Prefixed with project name"
project-prefixed-buffer-name) project-prefixed-buffer-name)
(function :tag "Custom function"))) (function :tag "Custom function")))

4
lisp/progmodes/prolog.el
View file

@ -828,7 +828,7 @@ Relevant only when `prolog-imenu-flag' is non-nil."
((not (zerop (skip-chars-forward prolog-operator-chars)))) ((not (zerop (skip-chars-forward prolog-operator-chars))))
((not (zerop (skip-syntax-forward "w_'")))) ((not (zerop (skip-syntax-forward "w_'"))))
;; In case of non-ASCII punctuation. ;; In case of non-ASCII punctuation.
((not (zerop (skip-syntax-forward "."))))) (t (skip-syntax-forward ".")))
(point)))) (point))))
(defun prolog-smie-backward-token () (defun prolog-smie-backward-token ()
@ -842,7 +842,7 @@ Relevant only when `prolog-imenu-flag' is non-nil."
((not (zerop (skip-chars-backward prolog-operator-chars)))) ((not (zerop (skip-chars-backward prolog-operator-chars))))
((not (zerop (skip-syntax-backward "w_'")))) ((not (zerop (skip-syntax-backward "w_'"))))
;; In case of non-ASCII punctuation. ;; In case of non-ASCII punctuation.
((not (zerop (skip-syntax-backward "."))))) (t (skip-syntax-backward ".")))
(point)))) (point))))
(defconst prolog-smie-grammar (defconst prolog-smie-grammar

16
test/lisp/emacs-lisp/nadvice-tests.el
View file

@ -118,20 +118,20 @@
(declare-function sm-test7 nil) (declare-function sm-test7 nil)
(advice-add 'sm-test7 :around (advice-add 'sm-test7 :around
(lambda (f &rest args) (lambda (f &rest args)
(list (cons 1 (called-interactively-p)) (apply f args)))) (list (cons 1 (called-interactively-p 'any)) (apply f args))))
(should (equal (sm-test7) '((1 . nil) 11))) (should (equal (sm-test7) '((1 . nil) 11)))
(should (equal (call-interactively 'sm-test7) '((1 . t) 11))) (should (equal (call-interactively 'sm-test7) '((1 . t) 11)))
(let ((smi 7)) (let ((smi 7))
(advice-add 'sm-test7 :before (advice-add 'sm-test7 :before
(lambda (&rest _args) (lambda (&rest _args)
(setq smi (called-interactively-p)))) (setq smi (called-interactively-p 'any))))
(should (equal (list (sm-test7) smi) (should (equal (list (sm-test7) smi)
'(((1 . nil) 11) nil))) '(((1 . nil) 11) nil)))
(should (equal (list (call-interactively 'sm-test7) smi) (should (equal (list (call-interactively 'sm-test7) smi)
'(((1 . t) 11) t)))) '(((1 . t) 11) t))))
(advice-add 'sm-test7 :around (advice-add 'sm-test7 :around
(lambda (f &rest args) (lambda (f &rest args)
(cons (cons 2 (called-interactively-p)) (apply f args)))) (cons (cons 2 (called-interactively-p 'any)) (apply f args))))
(should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11)))) (should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11))))
(ert-deftest advice-test-called-interactively-p-around () (ert-deftest advice-test-called-interactively-p-around ()
@ -140,18 +140,18 @@
This tests the currently broken case of the innermost advice to a This tests the currently broken case of the innermost advice to a
function being an around advice." function being an around advice."
:expected-result :failed :expected-result :failed
(defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p))) (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p 'any)))
(declare-function sm-test7.2 nil) (declare-function sm-test7.2 nil)
(advice-add 'sm-test7.2 :around (advice-add 'sm-test7.2 :around
(lambda (f &rest args) (lambda (f &rest args)
(list (cons 1 (called-interactively-p)) (apply f args)))) (list (cons 1 (called-interactively-p 'any)) (apply f args))))
(should (equal (sm-test7.2) '((1 . nil) (1 . nil)))) (should (equal (sm-test7.2) '((1 . nil) (1 . nil))))
(should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t))))) (should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t)))))
(ert-deftest advice-test-called-interactively-p-filter-args () (ert-deftest advice-test-called-interactively-p-filter-args ()
"Check interaction between filter-args advice and called-interactively-p." "Check interaction between filter-args advice and called-interactively-p."
:expected-result :failed :expected-result :failed
(defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p))) (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p 'any)))
(declare-function sm-test7.3 nil) (declare-function sm-test7.3 nil)
(advice-add 'sm-test7.3 :filter-args #'list) (advice-add 'sm-test7.3 :filter-args #'list)
(should (equal (sm-test7.3) '(1 . nil))) (should (equal (sm-test7.3) '(1 . nil)))
@ -159,7 +159,9 @@ function being an around advice."
(ert-deftest advice-test-call-interactively () (ert-deftest advice-test-call-interactively ()
"Check interaction between advice on call-interactively and called-interactively-p." "Check interaction between advice on call-interactively and called-interactively-p."
(let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p)))) (let ((sm-test7.4 (lambda ()
(interactive)
(cons 1 (called-interactively-p 'any))))
(old (symbol-function 'call-interactively))) (old (symbol-function 'call-interactively)))
(unwind-protect (unwind-protect
(progn (progn

37
test/lisp/net/tramp-tests.el
View file

@ -2412,22 +2412,51 @@ This checks also `file-name-as-directory', `file-name-directory',
(with-temp-buffer (with-temp-buffer
(write-region "foo" nil tmp-name) (write-region "foo" nil tmp-name)
(let ((point (point))) (let ((point (point)))
(insert-file-contents tmp-name) (should
(equal
(insert-file-contents tmp-name)
`(,(expand-file-name tmp-name) 3)))
(should (string-equal (buffer-string) "foo")) (should (string-equal (buffer-string) "foo"))
(should (= point (point)))) (should (= point (point))))
(goto-char (1+ (point))) (goto-char (1+ (point)))
(let ((point (point))) (let ((point (point)))
(insert-file-contents tmp-name) (should
(equal
(insert-file-contents tmp-name)
`(,(expand-file-name tmp-name) 3)))
(should (string-equal (buffer-string) "ffoooo")) (should (string-equal (buffer-string) "ffoooo"))
(should (= point (point)))) (should (= point (point))))
;; Insert partly. ;; Insert partly.
(let ((point (point))) (let ((point (point)))
(insert-file-contents tmp-name nil 1 3) (should
(equal
(insert-file-contents tmp-name nil 1 3)
`(,(expand-file-name tmp-name) 2)))
(should (string-equal (buffer-string) "foofoooo")) (should (string-equal (buffer-string) "foofoooo"))
(should (= point (point)))) (should (= point (point))))
(let ((point (point)))
(should
(equal
(insert-file-contents tmp-name nil 2 5)
`(,(expand-file-name tmp-name) 1)))
(should (string-equal (buffer-string) "fooofoooo"))
(should (= point (point))))
;; Replace. ;; Replace.
(let ((point (point))) (let ((point (point)))
(insert-file-contents tmp-name nil nil nil 'replace) ;; 0 characters replaced, because "foo" is already there.
(should
(equal
(insert-file-contents tmp-name nil nil nil 'replace)
`(,(expand-file-name tmp-name) 0)))
(should (string-equal (buffer-string) "foo"))
(should (= point (point))))
(let ((point (point)))
(replace-string-in-region "foo" "bar" (point-min) (point-max))
(goto-char point)
(should
(equal
(insert-file-contents tmp-name nil nil nil 'replace)
`(,(expand-file-name tmp-name) 3)))
(should (string-equal (buffer-string) "foo")) (should (string-equal (buffer-string) "foo"))
(should (= point (point)))) (should (= point (point))))
;; Error case. ;; Error case.

63
test/lisp/progmodes/eglot-tests.el
View file

@ -37,8 +37,8 @@
;; value (FIXME: like what?) in order to overwrite the default value. ;; value (FIXME: like what?) in order to overwrite the default value.
;; ;;
;; IMPORTANT: Since Eglot is a :core ELPA package, these tests are ;; IMPORTANT: Since Eglot is a :core ELPA package, these tests are
;;supposed to run on Emacsen down to 26.3. Do not use bleeding-edge ;; supposed to run on Emacsen down to 26.3. Do not use bleeding-edge
;;functionality not compatible with that Emacs version. ;; functionality not compatible with that Emacs version.
;;; Code: ;;; Code:
(require 'eglot) (require 'eglot)
@ -61,16 +61,13 @@
(apply #'format format args))) (apply #'format format args)))
(defmacro eglot--with-fixture (fixture &rest body) (defmacro eglot--with-fixture (fixture &rest body)
"Setup FIXTURE, call BODY, teardown FIXTURE. "Set up FIXTURE, call BODY, tear down FIXTURE.
FIXTURE is a list. Its elements are of the form (FILE . CONTENT) FIXTURE is a list. Its elements are of the form (FILE . CONTENT)
to create a readable FILE with CONTENT. FILE may be a directory to create a readable FILE with CONTENT. FILE may be a directory
name and CONTENT another (FILE . CONTENT) list to specify a name and CONTENT another (FILE . CONTENT) list to specify a
directory hierarchy. FIXTURE's elements can also be (SYMBOL directory hierarchy."
VALUE) meaning SYMBOL should be bound to VALUE during BODY and
then restored."
(declare (indent 1) (debug t)) (declare (indent 1) (debug t))
`(eglot--call-with-fixture `(eglot--call-with-fixture ,fixture (lambda () ,@body)))
,fixture #'(lambda () ,@body)))
(defun eglot--make-file-or-dir (ass) (defun eglot--make-file-or-dir (ass)
(let ((file-or-dir-name (car ass)) (let ((file-or-dir-name (car ass))
@ -91,18 +88,9 @@ then restored."
"Helper for `eglot--with-fixture'. Run FN under FIXTURE." "Helper for `eglot--with-fixture'. Run FN under FIXTURE."
(let* ((fixture-directory (make-nearby-temp-file "eglot--fixture" t)) (let* ((fixture-directory (make-nearby-temp-file "eglot--fixture" t))
(default-directory fixture-directory) (default-directory fixture-directory)
file-specs created-files created-files
syms-to-restore
new-servers new-servers
test-body-successful-p) test-body-successful-p)
(dolist (spec fixture)
(cond ((symbolp spec)
(push (cons spec (symbol-value spec)) syms-to-restore)
(set spec nil))
((symbolp (car spec))
(push (cons (car spec) (symbol-value (car spec))) syms-to-restore)
(set (car spec) (cadr spec)))
((stringp (car spec)) (push spec file-specs))))
(eglot--test-message "[%s]: test start" (ert-test-name (ert-running-test))) (eglot--test-message "[%s]: test start" (ert-test-name (ert-running-test)))
(unwind-protect (unwind-protect
(let* ((process-environment (let* ((process-environment
@ -123,7 +111,7 @@ then restored."
process-environment)) process-environment))
(eglot-server-initialized-hook (eglot-server-initialized-hook
(lambda (server) (push server new-servers)))) (lambda (server) (push server new-servers))))
(setq created-files (mapcan #'eglot--make-file-or-dir file-specs)) (setq created-files (mapcan #'eglot--make-file-or-dir fixture))
(prog1 (funcall fn) (prog1 (funcall fn)
(setq test-body-successful-p t))) (setq test-body-successful-p t)))
(eglot--test-message "[%s]: %s" (ert-test-name (ert-running-test)) (eglot--test-message "[%s]: %s" (ert-test-name (ert-running-test))
@ -155,18 +143,15 @@ then restored."
(t (t
(eglot--test-message "Preserved for inspection: %s" (eglot--test-message "Preserved for inspection: %s"
(mapconcat #'buffer-name buffers ", ")))))))) (mapconcat #'buffer-name buffers ", "))))))))
(eglot--cleanup-after-test fixture-directory created-files syms-to-restore))))) (eglot--cleanup-after-test fixture-directory created-files)))))
(defun eglot--cleanup-after-test (fixture-directory created-files syms-to-restore) (defun eglot--cleanup-after-test (fixture-directory created-files)
(let ((buffers-to-delete (let ((buffers-to-delete
(delete nil (mapcar #'find-buffer-visiting created-files)))) (delq nil (mapcar #'find-buffer-visiting created-files))))
(eglot--test-message "Killing %s, wiping %s, restoring %s" (eglot--test-message "Killing %s, wiping %s"
buffers-to-delete buffers-to-delete
fixture-directory fixture-directory)
(mapcar #'car syms-to-restore)) (dolist (buf buffers-to-delete) ;; Have to save otherwise will get prompted.
(cl-loop for (sym . val) in syms-to-restore
do (set sym val))
(dolist (buf buffers-to-delete) ;; have to save otherwise will get prompted
(with-current-buffer buf (save-buffer) (kill-buffer))) (with-current-buffer buf (save-buffer) (kill-buffer)))
(delete-directory fixture-directory 'recursive) (delete-directory fixture-directory 'recursive)
;; Delete Tramp buffers if needed. ;; Delete Tramp buffers if needed.
@ -325,8 +310,7 @@ then restored."
"Connect to eclipse.jdt.ls server." "Connect to eclipse.jdt.ls server."
(skip-unless (executable-find "jdtls")) (skip-unless (executable-find "jdtls"))
(eglot--with-fixture (eglot--with-fixture
'(("project/src/main/java/foo" . (("Main.java" . ""))) '(("project/src/main/java/foo" . (("Main.java" . ""))))
("project/.git/" . nil))
(with-current-buffer (with-current-buffer
(eglot--find-file-noselect "project/src/main/java/foo/Main.java") (eglot--find-file-noselect "project/src/main/java/foo/Main.java")
(eglot--sniffing (:server-notifications s-notifs) (eglot--sniffing (:server-notifications s-notifs)
@ -480,11 +464,11 @@ then restored."
(should (eq 'eglot-diagnostic-tag-unnecessary-face (face-at-point)))))))) (should (eq 'eglot-diagnostic-tag-unnecessary-face (face-at-point))))))))
(defun eglot--eldoc-on-demand () (defun eglot--eldoc-on-demand ()
;; Trick Eldoc 1.1.0 into accepting on-demand calls. ;; Trick ElDoc 1.1.0 into accepting on-demand calls.
(eldoc t)) (eldoc t))
(defun eglot--tests-force-full-eldoc () (defun eglot--tests-force-full-eldoc ()
;; FIXME: This uses some Eldoc implementation defatils. ;; FIXME: This uses some ElDoc implementation details.
(when (buffer-live-p eldoc--doc-buffer) (when (buffer-live-p eldoc--doc-buffer)
(with-current-buffer eldoc--doc-buffer (with-current-buffer eldoc--doc-buffer
(let ((inhibit-read-only t)) (let ((inhibit-read-only t))
@ -670,7 +654,7 @@ int main() {
(should (string-match "^fprintf" (eglot--tests-force-full-eldoc)))))) (should (string-match "^fprintf" (eglot--tests-force-full-eldoc))))))
(ert-deftest eglot-test-multiline-eldoc () (ert-deftest eglot-test-multiline-eldoc ()
"Test Eldoc documentation from multiple osurces." "Test ElDoc documentation from multiple osurces."
(skip-unless (executable-find "clangd")) (skip-unless (executable-find "clangd"))
(eglot--with-fixture (eglot--with-fixture
`(("project" . (("coiso.c" . `(("project" . (("coiso.c" .
@ -723,7 +707,7 @@ int main() {
(eglot--sniffing (:server-notifications s-notifs) (eglot--sniffing (:server-notifications s-notifs)
(should (eglot--tests-connect)) (should (eglot--tests-connect))
(eglot--wait-for (s-notifs 20) (&key method &allow-other-keys) (eglot--wait-for (s-notifs 20) (&key method &allow-other-keys)
(string= method "textDocument/publishDiagnostics"))) (string= method "textDocument/publishDiagnostics")))
(goto-char (point-max)) (goto-char (point-max))
(eglot--simulate-key-event ?.) (eglot--simulate-key-event ?.)
(should (looking-back "^ \\.")))))) (should (looking-back "^ \\."))))))
@ -872,9 +856,9 @@ int main() {
(skip-unless (executable-find "clangd")) (skip-unless (executable-find "clangd"))
(eglot--with-fixture (eglot--with-fixture
`(("project" . (("foo.c" . "int foo() {return 42;}") `(("project" . (("foo.c" . "int foo() {return 42;}")
("bar.c" . "int bar() {return 42;}"))) ("bar.c" . "int bar() {return 42;}"))))
(c-mode-hook (eglot-ensure))) (let ((c-mode-hook '(eglot-ensure))
(let (server) server)
;; need `ert-simulate-command' because `eglot-ensure' ;; need `ert-simulate-command' because `eglot-ensure'
;; relies on `post-command-hook'. ;; relies on `post-command-hook'.
(with-current-buffer (with-current-buffer
@ -1288,7 +1272,7 @@ macro will assume it exists."
(ert-deftest eglot-test-path-to-uri-windows () (ert-deftest eglot-test-path-to-uri-windows ()
(skip-unless (eq system-type 'windows-nt)) (skip-unless (eq system-type 'windows-nt))
(should (string-prefix-p "file:///" (should (string-prefix-p "file:///"
(eglot--path-to-uri "c:/Users/Foo/bar.lisp"))) (eglot--path-to-uri "c:/Users/Foo/bar.lisp")))
(should (string-suffix-p "c%3A/Users/Foo/bar.lisp" (should (string-suffix-p "c%3A/Users/Foo/bar.lisp"
(eglot--path-to-uri "c:/Users/Foo/bar.lisp")))) (eglot--path-to-uri "c:/Users/Foo/bar.lisp"))))
@ -1318,8 +1302,9 @@ macro will assume it exists."
(should (eq (eglot-current-server) server)))))) (should (eq (eglot-current-server) server))))))
(provide 'eglot-tests) (provide 'eglot-tests)
;;; eglot-tests.el ends here
;; Local Variables: ;; Local Variables:
;; checkdoc-force-docstrings-flag: nil ;; checkdoc-force-docstrings-flag: nil
;; End: ;; End:
;;; eglot-tests.el ends here

39
test/src/fns-tests.el
View file

@ -114,22 +114,24 @@
(should-error (nreverse 1)) (should-error (nreverse 1))
(should-error (nreverse (make-char-table 'foo))) (should-error (nreverse (make-char-table 'foo)))
(should (equal (nreverse (copy-sequence "xyzzy")) "yzzyx")) (should (equal (nreverse (copy-sequence "xyzzy")) "yzzyx"))
(let ((A (vector))) (let* ((A (vector))
(nreverse A) (B (nreverse A)))
(should (equal A []))) (should (equal A []))
(let ((A (vector 0))) (should (eq B A)))
(nreverse A) (let* ((A (vector 0))
(should (equal A [0]))) (B (nreverse A)))
(let ((A (vector 1 2 3 4))) (should (equal A [0]))
(nreverse A) (should (eq B A)))
(should (equal A [4 3 2 1])))
(let ((A (vector 1 2 3 4)))
(nreverse A)
(nreverse A)
(should (equal A [1 2 3 4])))
(let* ((A (vector 1 2 3 4)) (let* ((A (vector 1 2 3 4))
(B (nreverse (nreverse A)))) (B (nreverse A)))
(should (equal A B)))) (should (equal A [4 3 2 1]))
(should (eq B A)))
(let* ((A (vector 1 2 3 4))
(B (nreverse A))
(C (nreverse A)))
(should (equal A [1 2 3 4]))
(should (eq B A))
(should (eq C A))))
(ert-deftest fns-tests-reverse-bool-vector () (ert-deftest fns-tests-reverse-bool-vector ()
(let ((A (make-bool-vector 10 nil))) (let ((A (make-bool-vector 10 nil)))
@ -140,9 +142,10 @@
(ert-deftest fns-tests-nreverse-bool-vector () (ert-deftest fns-tests-nreverse-bool-vector ()
(let ((A (make-bool-vector 10 nil))) (let ((A (make-bool-vector 10 nil)))
(dotimes (i 5) (aset A i t)) (dotimes (i 5) (aset A i t))
(nreverse A) (let ((B (nreverse A)))
(should (equal [nil nil nil nil nil t t t t t] (vconcat A))) (should (eq B A))
(should (equal [t t t t t nil nil nil nil nil] (vconcat (nreverse A)))))) (should (equal [nil nil nil nil nil t t t t t] (vconcat A)))
(should (equal [t t t t t nil nil nil nil nil] (vconcat (nreverse A)))))))
(defconst fns-tests--string-lessp-cases (defconst fns-tests--string-lessp-cases
`(("abc" < "abd") `(("abc" < "abd")