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

Merge remote-tracking branch 'refs/remotes/origin/master'

Browse source
This commit is contained in:
Stefan Monnier 2023-09-04 16:42:15 -04:00
commit 9e05453a8c
31 changed files with 491 additions and 287 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

149
doc/misc/eglot.texi
View file

@ -99,6 +99,7 @@ This manual documents how to configure, use, and customize Eglot.
* Using Eglot:: Important Eglot commands and variables.
* Customizing Eglot:: Eglot customization and advanced features.
* Advanced server configuration:: Fine-tune a specific language server
* Extending Eglot:: Writing Eglot extensions in Elisp
* Troubleshooting Eglot:: Troubleshooting and reporting bugs.
* GNU Free Documentation License:: The license for this manual.
* Index::
@ -1264,6 +1265,154 @@ is serialized by Eglot to the following JSON text:
@}
@end example
@node Extending Eglot
@chapter Extending Eglot
Sometimes it may be useful to extend existing Eglot functionality
using Elisp its public methods. A good example of when this need may
arise is adding support for a custom LSP protocol extension only
implemented by a specific server.
The best source of documentation for this is probably Eglot source
code itself, particularly the section marked ``API''.
Most of the functionality is implemented with Common-Lisp style
generic functions (@pxref{Generics,,,eieio,EIEIO}) that can be easily
extended or overridden. The Eglot code itself is an example on how to
do this.
The following is a relatively simple example that adds support for the
@code{inactiveRegions} experimental feature introduced in version 17
of the @command{clangd} C/C++ language server++.
Summarily, the feature works by first having the server detect the
Eglot's advertisement of the @code{inactiveRegions} client capability
during startup, whereupon the language server will report a list of
regions of inactive code for each buffer. This is usually code
surrounded by C/C++ @code{#ifdef} macros that the preprocessor removes
based on compile-time information.
The language server reports the regions by periodically sending a
@code{textDocument/inactiveRegions} notification for each managed
buffer (@pxref{Eglot and Buffers}). Normally, unknown server
notifications are ignored by Eglot, but we're going change that.
Both the announcement of the client capability and the handling of the
new notification is done by adding methods to generic functions.
@itemize @bullet
@item
The first method extends @code{eglot-client-capabilities} using a
simple heuristic to detect if current server is @command{clangd} and
enables the @code{inactiveRegion} capability.
@lisp
(cl-defmethod eglot-client-capabilities :around (server)
(let ((base (cl-call-next-method)))
(when (cl-find "clangd" (process-command
(jsonrpc--process server))
:test #'string-match)
(setf (cl-getf (cl-getf base :textDocument)
:inactiveRegionsCapabilities)
'(:inactiveRegions t)))
base))
@end lisp
Notice we use an internal function of the @code{jsonrpc.el} library,
and a regexp search to detect @command{clangd}. An alternative would
be to define a new EIEIO subclass of @code{eglot-lsp-server}, maybe
called @code{eglot-clangd}, so that the method would be simplified:
@lisp
(cl-defmethod eglot-client-capabilities :around ((_s eglot-clangd))
(let ((base (cl-call-next-method)))
(setf (cl-getf (cl-getf base :textDocument)
:inactiveRegionsCapabilities)
'(:inactiveRegions t))))
@end lisp
However, this would require that users tweak
@code{eglot-server-program} to tell Eglot instantiate such sub-classes
instead of the generic @code{eglot-lsp-server} (@pxref{Setting Up LSP
Servers}). For the purposes of this particular demonstration, we're
going to use the more hacky regexp route which doesn't require that.
Note, however, that detecting server versions before announcing new
capabilities is generally not needed, as both server and client are
required by LSP to ignore unknown capabilities advertised by their
counterparts.
@item
The second method implements @code{eglot-handle-notification} to
process the server notification for the LSP method
@code{textDocument/inactiveRegions}. For each region received it
creates an overlay applying the @code{shadow} face to the region.
Overlays are recreated every time a new notification of this kind is
received.
To learn about how @command{clangd}'s special JSONRPC notification
message is structured in detail you could consult that server's
documentation. Another possibility is to evaluate the first
capability-announcing method, reconnect to the server and peek in the
events buffer (@pxref{Eglot Commands, eglot-events-buffer}). You
could find something like:
@lisp
[server-notification] Mon Sep 4 01:10:04 2023:
(:jsonrpc "2.0" :method "textDocument/inactiveRegions" :params
(:textDocument
(:uri "file:///path/to/file.cpp")
:regions
[(:start (:character 0 :line 18)
:end (:character 58 :line 19))
(:start (:character 0 :line 36)
:end (:character 1 :line 38))]))
@end lisp
This reveals that the @code{textDocument/inactiveRegions} notification
contains a @code{:textDocument} property to designate the managed
buffer and an array of LSP regions under the @code{:regions} property.
Notice how the message (originally in JSON format), is represented as
Elisp plists (@pxref{JSONRPC objects in Elisp}).
The Eglot generic function machinery will automatically destructure
the incoming message, so these two properties can simply be added to
the new method's lambda list as @code{&key} arguments. Also, the
@code{eglot-uri-to-path} and@code{eglot-range-region} may be used to
easily parse the LSP @code{:uri} and @code{:start ... :end ...}
objects to obtain Emacs objects for file names and positions.
The remainder of the implementation consists of standard Elisp
techniques to loop over arrays, manage buffers and overlays.
@lisp
(defvar-local eglot-clangd-inactive-region-overlays '())
(cl-defmethod eglot-handle-notification
(_server (_method (eql textDocument/inactiveRegions))
&key regions textDocument &allow-other-keys)
(if-let* ((path (expand-file-name (eglot-uri-to-path
(cl-getf textDocument :uri))))
(buffer (find-buffer-visiting path)))
(with-current-buffer buffer
(mapc #'delete-overlay eglot-clangd-inactive-region-overlays)
(cl-loop
for r across regions
for (beg . end) = (eglot-range-region r)
for ov = (make-overlay beg end)
do
(overlay-put ov 'face 'shadow)
(push ov eglot-clangd-inactive-region-overlays)))))
@end lisp
@end itemize
After evaluating these two additions and reconnecting to the
@command{clangd} language server (version 17), the result will be that
all the inactive code in the buffer will be nicely grayed out using
the LSP server knowledge about current compile time preprocessor
defines.
@node Troubleshooting Eglot
@chapter Troubleshooting Eglot
@cindex troubleshooting Eglot

23
doc/misc/ert.texi
View file

@ -658,11 +658,30 @@ versions, specific architectures, etc.:
@cindex skipping tests
@cindex test preconditions
@cindex preconditions of a test
@findex skip-when
@findex skip-unless
Sometimes, it doesn't make sense to run a test due to missing
preconditions. A required Emacs feature might not be compiled in, the
function to be tested could call an external binary which might not be
available on the test machine, you name it. In this case, the macro
@code{skip-unless} could be used to skip the test:
available on the test machine, you name it. In this case, the macros
@code{skip-when} or @code{skip-unless} could be used to skip the
test.@footnote{The @code{skip-when} macro was added in Emacs 30.1. If
you need your tests to be compatible with older versions of Emacs, use
@code{skip-unless} instead.}
@noindent
For example, this test is skipped on MS-Windows and macOS:
@lisp
(ert-deftest test-gnu-linux ()
"A test that is not relevant on MS-Windows and macOS."
(skip-when (memq system-type '(windows-nt ns))
...))
@end lisp
@noindent
This test is skipped if the feature @samp{dbusbind} is not present in
the running Emacs:
@lisp
(ert-deftest test-dbus ()

7
etc/NEWS
View file

@ -724,6 +724,13 @@ without specifying a file, like this:
*** New user option 'image-dired-thumb-naming'.
You can now configure how a thumbnail is named using this option.
** ERT
*** New macro `skip-when' to skip 'ert-deftest' tests.
This can help avoid some awkward skip conditions. For example
'(skip-unless (not noninteractive))' can be changed to the easier
to read '(skip-when noninteractive)'.
** checkdoc
---

39
lisp/emacs-lisp/ert.el
View file

@ -34,17 +34,18 @@
;; `ert-run-tests-batch-and-exit' for non-interactive use.
;;
;; The body of `ert-deftest' forms resembles a function body, but the
;; additional operators `should', `should-not', `should-error' and
;; `skip-unless' are available. `should' is similar to cl's `assert',
;; but signals a different error when its condition is violated that
;; is caught and processed by ERT. In addition, it analyzes its
;; argument form and records information that helps debugging
;; (`cl-assert' tries to do something similar when its second argument
;; SHOW-ARGS is true, but `should' is more sophisticated). For
;; information on `should-not' and `should-error', see their
;; docstrings. `skip-unless' skips the test immediately without
;; processing further, this is useful for checking the test
;; environment (like availability of features, external binaries, etc).
;; additional operators `should', `should-not', `should-error',
;; `skip-when' and `skip-unless' are available. `should' is similar
;; to cl's `assert', but signals a different error when its condition
;; is violated that is caught and processed by ERT. In addition, it
;; analyzes its argument form and records information that helps
;; debugging (`cl-assert' tries to do something similar when its
;; second argument SHOW-ARGS is true, but `should' is more
;; sophisticated). For information on `should-not' and
;; `should-error', see their docstrings. The `skip-when' and
;; `skip-unless' forms skip the test immediately, which is useful for
;; checking the test environment (like availability of features,
;; external binaries, etc).
;;
;; See ERT's Info manual `(ert) Top' as well as the docstrings for
;; more details. To see some examples of tests written in ERT, see
@ -194,8 +195,8 @@ and the body."
BODY is evaluated as a `progn' when the test is run. It should
signal a condition on failure or just return if the test passes.
`should', `should-not', `should-error' and `skip-unless' are
useful for assertions in BODY.
`should', `should-not', `should-error', `skip-when', and
`skip-unless' are useful for assertions in BODY.
Use `ert' to run tests interactively.
@ -227,7 +228,8 @@ in batch mode, an error is signaled.
(tags nil tags-supplied-p))
body)
(ert--parse-keys-and-body docstring-keys-and-body)
`(cl-macrolet ((skip-unless (form) `(ert--skip-unless ,form)))
`(cl-macrolet ((skip-when (form) `(ert--skip-when ,form))
(skip-unless (form) `(ert--skip-unless ,form)))
(ert-set-test ',name
(make-ert-test
:name ',name
@ -464,6 +466,15 @@ failed."
(list
:fail-reason "did not signal an error")))))))))
(cl-defmacro ert--skip-when (form)
"Evaluate FORM. If it returns t, skip the current test.
Errors during evaluation are caught and handled like t."
(declare (debug t))
(ert--expand-should `(skip-when ,form) form
(lambda (inner-form form-description-form _value-var)
`(when (condition-case nil ,inner-form (t t))
(ert-skip ,form-description-form)))))
(cl-defmacro ert--skip-unless (form)
"Evaluate FORM. If it returns nil, skip the current test.
Errors during evaluation are caught and handled like nil."

5
lisp/net/shr.el
View file

@ -2617,11 +2617,12 @@ flags that control whether to collect or render objects."
columns))
(defun shr-count (dom elem)
;; This is faster than `seq-count', and shr can use it.
(let ((i 0))
(dolist (sub (dom-children dom))
(when (and (not (stringp sub))
(eq (dom-tag sub) elem))
(setq i (1+ i))))
(eq (dom-tag sub) elem))
(setq i (1+ i))))
i))
(defun shr-max-columns (dom)

392
lisp/progmodes/eglot.el
View file

@ -131,6 +131,35 @@
(defvar tramp-ssh-controlmaster-options)
(defvar tramp-use-ssh-controlmaster-options)
;;; Obsolete aliases
;;;
(make-obsolete-variable 'eglot--managed-mode-hook
'eglot-managed-mode-hook "1.6")
(define-obsolete-variable-alias 'eglot-confirm-server-initiated-edits
'eglot-confirm-server-edits "1.16")
(define-obsolete-function-alias 'eglot--uri-to-path 'eglot-uri-to-path "1.16")
(define-obsolete-function-alias 'eglot--path-to-uri 'eglot-path-to-uri "1.16")
(define-obsolete-function-alias 'eglot--range-region 'eglot-range-region "1.16")
(define-obsolete-function-alias 'eglot--server-capable 'eglot-server-capable "1.16")
(define-obsolete-function-alias 'eglot--server-capable-or-lose 'eglot-server-capable-or-lose "1.16")
(define-obsolete-function-alias
'eglot-lsp-abiding-column 'eglot-utf-16-linepos "1.12")
(define-obsolete-function-alias
'eglot-current-column 'eglot-utf-32-linepos "1.12")
(define-obsolete-variable-alias
'eglot-current-column-function 'eglot-current-linepos-function "1.12")
(define-obsolete-function-alias
'eglot-move-to-current-column 'eglot-move-to-utf-32-linepos "1.12")
(define-obsolete-function-alias
'eglot-move-to-lsp-abiding-column 'eglot-move-to-utf-16-linepos "1.12")
(define-obsolete-variable-alias
'eglot-move-to-column-function 'eglot-move-to-linepos-function "1.12")
(define-obsolete-variable-alias 'eglot-ignored-server-capabilites
'eglot-ignored-server-capabilities "1.8")
;;;###autoload
(define-obsolete-function-alias 'eglot-update 'eglot-upgrade-eglot "29.1")
;;; User tweakable stuff
(defgroup eglot nil
@ -391,9 +420,6 @@ done by `eglot-reconnect'."
:type '(choice (const :tag "No limit" nil)
(integer :tag "Number of characters")))
(define-obsolete-variable-alias 'eglot-confirm-server-initiated-edits
'eglot-confirm-server-edits "1.16")
(defcustom eglot-confirm-server-edits '((eglot-rename . nil)
(t . maybe-summary))
"Control if changes proposed by LSP should be confirmed with user.
@ -444,6 +470,36 @@ mode line indicator."
:type 'boolean
:version "1.10")
(defcustom eglot-ignored-server-capabilities (list)
"LSP server capabilities that Eglot could use, but won't.
You could add, for instance, the symbol
`:documentHighlightProvider' to prevent automatic highlighting
under cursor."
:type '(set
:tag "Tick the ones you're not interested in"
(const :tag "Documentation on hover" :hoverProvider)
(const :tag "Code completion" :completionProvider)
(const :tag "Function signature help" :signatureHelpProvider)
(const :tag "Go to definition" :definitionProvider)
(const :tag "Go to type definition" :typeDefinitionProvider)
(const :tag "Go to implementation" :implementationProvider)
(const :tag "Go to declaration" :declarationProvider)
(const :tag "Find references" :referencesProvider)
(const :tag "Highlight symbols automatically" :documentHighlightProvider)
(const :tag "List symbols in buffer" :documentSymbolProvider)
(const :tag "List symbols in workspace" :workspaceSymbolProvider)
(const :tag "Execute code actions" :codeActionProvider)
(const :tag "Code lens" :codeLensProvider)
(const :tag "Format buffer" :documentFormattingProvider)
(const :tag "Format portion of buffer" :documentRangeFormattingProvider)
(const :tag "On-type formatting" :documentOnTypeFormattingProvider)
(const :tag "Rename symbol" :renameProvider)
(const :tag "Highlight links in document" :documentLinkProvider)
(const :tag "Decorate color references" :colorProvider)
(const :tag "Fold regions of buffer" :foldingRangeProvider)
(const :tag "Execute custom commands" :executeCommandProvider)
(const :tag "Inlay hints" :inlayHintProvider)))
(defvar eglot-withhold-process-id nil
"If non-nil, Eglot will not send the Emacs process id to the language server.
This can be useful when using docker to run a language server.")
@ -488,6 +544,7 @@ It is nil if Eglot is not byte-complied.")
(2 . eglot-diagnostic-tag-deprecated-face)))
(defvaralias 'eglot-{} 'eglot--{})
(defconst eglot--{} (make-hash-table :size 1) "The empty JSON object.")
(defun eglot--executable-find (command &optional remote)
@ -499,6 +556,12 @@ It is nil if Eglot is not byte-complied.")
(if (and (not eglot-prefer-plaintext) (fboundp 'gfm-view-mode))
["markdown" "plaintext"] ["plaintext"]))
(defconst eglot--uri-path-allowed-chars
(let ((vec (copy-sequence url-path-allowed-chars)))
(aset vec ?: nil) ;; see github#639
vec)
"Like `url-path-allows-chars' but more restrictive.")
;;; Message verification helpers
;;;
@ -692,7 +755,6 @@ Honor `eglot-strict-mode'."
(cl-destructuring-bind (&key ,@vars &allow-other-keys) ,object-once
(funcall ,fn-once ,@vars))))))))
(cl-defmacro eglot--lambda (cl-lambda-list &body body)
"Function of args CL-LAMBDA-LIST for processing INTERFACE objects.
Honor `eglot-strict-mode'."
@ -741,9 +803,6 @@ treated as in `eglot--dbind'."
,obj-once
',(mapcar #'car clauses)))))))
;;; API (WORK-IN-PROGRESS!)
;;;
(cl-defmacro eglot--when-live-buffer (buf &rest body)
"Check BUF live, then do BODY in it." (declare (indent 1) (debug t))
(let ((b (cl-gensym)))
@ -761,6 +820,9 @@ treated as in `eglot--dbind'."
"Save excursion and restriction. Widen. Then run BODY." (declare (debug t))
`(save-excursion (save-restriction (widen) ,@body)))
;;; Public Elisp API
;;;
(cl-defgeneric eglot-handle-request (server method &rest params)
"Handle SERVER's METHOD request with PARAMS.")
@ -783,7 +845,7 @@ ACTION is an LSP object of either `CodeAction' or `Command' type."
(((Command)) (eglot--request server :workspace/executeCommand action))
(((CodeAction) edit command data)
(if (and (null edit) (null command) data
(eglot--server-capable :codeActionProvider :resolveProvider))
(eglot-server-capable :codeActionProvider :resolveProvider))
(eglot-execute server (eglot--request server :codeAction/resolve action))
(when edit (eglot--apply-workspace-edit edit this-command))
(when command (eglot--request server :workspace/executeCommand command)))))))
@ -903,7 +965,7 @@ ACTION is an LSP object of either `CodeAction' or `Command' type."
(let ((project (eglot--project server)))
(vconcat
(mapcar (lambda (dir)
(list :uri (eglot--path-to-uri dir)
(list :uri (eglot-path-to-uri dir)
:name (abbreviate-file-name dir)))
`(,(project-root project) ,@(project-external-roots project))))))
@ -949,6 +1011,81 @@ ACTION is an LSP object of either `CodeAction' or `Command' type."
:documentation
"Represents a server. Wraps a process for LSP communication.")
(declare-function w32-long-file-name "w32proc.c" (fn))
(defun eglot-uri-to-path (uri)
"Convert URI to file path, helped by `eglot--current-server'."
(when (keywordp uri) (setq uri (substring (symbol-name uri) 1)))
(let* ((server (eglot-current-server))
(remote-prefix (and server (eglot--trampish-p server)))
(url (url-generic-parse-url uri)))
;; Only parse file:// URIs, leave other URI untouched as
;; `file-name-handler-alist' should know how to handle them
;; (bug#58790).
(if (string= "file" (url-type url))
(let* ((retval (url-unhex-string (url-filename url)))
;; Remove the leading "/" for local MS Windows-style paths.
(normalized (if (and (not remote-prefix)
(eq system-type 'windows-nt)
(cl-plusp (length retval)))
(w32-long-file-name (substring retval 1))
retval)))
(concat remote-prefix normalized))
uri)))
(defun eglot-path-to-uri (path)
"Convert PATH, a file name, to LSP URI string and return it."
(let ((truepath (file-truename path)))
(if (and (url-type (url-generic-parse-url path))
;; It might be MS Windows path which includes a drive
;; letter that looks like a URL scheme (bug#59338)
(not (and (eq system-type 'windows-nt)
(file-name-absolute-p truepath))))
;; Path is already a URI, so forward it to the LSP server
;; untouched. The server should be able to handle it, since
;; it provided this URI to clients in the first place.
path
(concat "file://"
;; Add a leading "/" for local MS Windows-style paths.
(if (and (eq system-type 'windows-nt)
(not (file-remote-p truepath)))
"/")
(url-hexify-string
;; Again watch out for trampy paths.
(directory-file-name (file-local-name truepath))
eglot--uri-path-allowed-chars)))))
(defun eglot-range-region (range &optional markers)
"Return a cons (BEG . END) of positions representing LSP RANGE.
If optional MARKERS, make markers instead."
(let* ((st (plist-get range :start))
(beg (eglot--lsp-position-to-point st markers))
(end (eglot--lsp-position-to-point (plist-get range :end) markers)))
(cons beg end)))
(defun eglot-server-capable (&rest feats)
"Determine if current server is capable of FEATS."
(unless (cl-some (lambda (feat)
(memq feat eglot-ignored-server-capabilities))
feats)
(cl-loop for caps = (eglot--capabilities (eglot--current-server-or-lose))
then (cadr probe)
for (feat . more) on feats
for probe = (plist-member caps feat)
if (not probe) do (cl-return nil)
if (eq (cadr probe) :json-false) do (cl-return nil)
if (not (listp (cadr probe))) do (cl-return (if more nil (cadr probe)))
finally (cl-return (or (cadr probe) t)))))
(defun eglot-server-capable-or-lose (&rest feats)
"Like `eglot-server-capable', but maybe error out."
(let ((retval (apply #'eglot-server-capable feats)))
(unless retval
(eglot--error "Unsupported or ignored LSP capability `%s'"
(mapconcat #'symbol-name feats " ")))
retval))
;;; Process/server management
(defun eglot--major-modes (s) "Major modes server S is responsible for."
(mapcar #'car (eglot--languages s)))
@ -958,8 +1095,6 @@ ACTION is an LSP object of either `CodeAction' or `Command' type."
(cl-defmethod initialize-instance :before ((_server eglot-lsp-server) &optional args)
(cl-remf args :initializationOptions))
;;; Process management
(defvar eglot--servers-by-project (make-hash-table :test #'equal)
"Keys are projects. Values are lists of processes.")
@ -1401,7 +1536,7 @@ This docstring appeases checkdoc, that's all."
;; into `/path/to/baz.py', so LSP groks it.
:rootPath (file-local-name
(expand-file-name default-directory))
:rootUri (eglot--path-to-uri default-directory)
:rootUri (eglot-path-to-uri default-directory)
:initializationOptions (eglot-initialization-options
server)
:capabilities (eglot-client-capabilities server)
@ -1556,13 +1691,6 @@ Unless IMMEDIATE, send pending changes before making request."
;;; Encoding fever
;;;
(define-obsolete-function-alias
'eglot-lsp-abiding-column 'eglot-utf-16-linepos "1.12")
(define-obsolete-function-alias
'eglot-current-column 'eglot-utf-32-linepos "1.12")
(define-obsolete-variable-alias
'eglot-current-column-function 'eglot-current-linepos-function "1.12")
(defvar eglot-current-linepos-function #'eglot-utf-16-linepos
"Function calculating position relative to line beginning.
@ -1601,13 +1729,6 @@ LBP defaults to `eglot--bol'."
:character (progn (when pos (goto-char pos))
(funcall eglot-current-linepos-function)))))
(define-obsolete-function-alias
'eglot-move-to-current-column 'eglot-move-to-utf-32-linepos "1.12")
(define-obsolete-function-alias
'eglot-move-to-lsp-abiding-column 'eglot-move-to-utf-16-linepos "1.12")
(define-obsolete-variable-alias
'eglot-move-to-column-function 'eglot-move-to-linepos-function "1.12")
(defvar eglot-move-to-linepos-function #'eglot-move-to-utf-16-linepos
"Function to move to a position within a line reported by the LSP server.
@ -1674,55 +1795,6 @@ If optional MARKER, return a marker instead"
;;; More helpers
(defconst eglot--uri-path-allowed-chars
(let ((vec (copy-sequence url-path-allowed-chars)))
(aset vec ?: nil) ;; see github#639
vec)
"Like `url-path-allows-chars' but more restrictive.")
(defun eglot--path-to-uri (path)
"URIfy PATH."
(let ((truepath (file-truename path)))
(if (and (url-type (url-generic-parse-url path))
;; It might be MS Windows path which includes a drive
;; letter that looks like a URL scheme (bug#59338)
(not (and (eq system-type 'windows-nt)
(file-name-absolute-p truepath))))
;; Path is already a URI, so forward it to the LSP server
;; untouched. The server should be able to handle it, since
;; it provided this URI to clients in the first place.
path
(concat "file://"
;; Add a leading "/" for local MS Windows-style paths.
(if (and (eq system-type 'windows-nt)
(not (file-remote-p truepath)))
"/")
(url-hexify-string
;; Again watch out for trampy paths.
(directory-file-name (file-local-name truepath))
eglot--uri-path-allowed-chars)))))
(declare-function w32-long-file-name "w32proc.c" (fn))
(defun eglot--uri-to-path (uri)
"Convert URI to file path, helped by `eglot--current-server'."
(when (keywordp uri) (setq uri (substring (symbol-name uri) 1)))
(let* ((server (eglot-current-server))
(remote-prefix (and server (eglot--trampish-p server)))
(url (url-generic-parse-url uri)))
;; Only parse file:// URIs, leave other URI untouched as
;; `file-name-handler-alist' should know how to handle them
;; (bug#58790).
(if (string= "file" (url-type url))
(let* ((retval (url-unhex-string (url-filename url)))
;; Remove the leading "/" for local MS Windows-style paths.
(normalized (if (and (not remote-prefix)
(eq system-type 'windows-nt)
(cl-plusp (length retval)))
(w32-long-file-name (substring retval 1))
retval)))
(concat remote-prefix normalized))
uri)))
(defun eglot--snippet-expansion-fn ()
"Compute a function to expand snippets.
Doubles as an indicator of snippet support."
@ -1757,69 +1829,6 @@ Doubles as an indicator of snippet support."
(prop-match-end match)))))
(string-trim (buffer-string))))))
(define-obsolete-variable-alias 'eglot-ignored-server-capabilites
'eglot-ignored-server-capabilities "1.8")
(defcustom eglot-ignored-server-capabilities (list)
"LSP server capabilities that Eglot could use, but won't.
You could add, for instance, the symbol
`:documentHighlightProvider' to prevent automatic highlighting
under cursor."
:type '(set
:tag "Tick the ones you're not interested in"
(const :tag "Documentation on hover" :hoverProvider)
(const :tag "Code completion" :completionProvider)
(const :tag "Function signature help" :signatureHelpProvider)
(const :tag "Go to definition" :definitionProvider)
(const :tag "Go to type definition" :typeDefinitionProvider)
(const :tag "Go to implementation" :implementationProvider)
(const :tag "Go to declaration" :declarationProvider)
(const :tag "Find references" :referencesProvider)
(const :tag "Highlight symbols automatically" :documentHighlightProvider)
(const :tag "List symbols in buffer" :documentSymbolProvider)
(const :tag "List symbols in workspace" :workspaceSymbolProvider)
(const :tag "Execute code actions" :codeActionProvider)
(const :tag "Code lens" :codeLensProvider)
(const :tag "Format buffer" :documentFormattingProvider)
(const :tag "Format portion of buffer" :documentRangeFormattingProvider)
(const :tag "On-type formatting" :documentOnTypeFormattingProvider)
(const :tag "Rename symbol" :renameProvider)
(const :tag "Highlight links in document" :documentLinkProvider)
(const :tag "Decorate color references" :colorProvider)
(const :tag "Fold regions of buffer" :foldingRangeProvider)
(const :tag "Execute custom commands" :executeCommandProvider)
(const :tag "Inlay hints" :inlayHintProvider)))
(defun eglot--server-capable (&rest feats)
"Determine if current server is capable of FEATS."
(unless (cl-some (lambda (feat)
(memq feat eglot-ignored-server-capabilities))
feats)
(cl-loop for caps = (eglot--capabilities (eglot--current-server-or-lose))
then (cadr probe)
for (feat . more) on feats
for probe = (plist-member caps feat)
if (not probe) do (cl-return nil)
if (eq (cadr probe) :json-false) do (cl-return nil)
if (not (listp (cadr probe))) do (cl-return (if more nil (cadr probe)))
finally (cl-return (or (cadr probe) t)))))
(defun eglot--server-capable-or-lose (&rest feats)
"Like `eglot--server-capable', but maybe error out."
(let ((retval (apply #'eglot--server-capable feats)))
(unless retval
(eglot--error "Unsupported or ignored LSP capability `%s'"
(mapconcat #'symbol-name feats " ")))
retval))
(defun eglot--range-region (range &optional markers)
"Return region (BEG . END) that represents LSP RANGE.
If optional MARKERS, make markers."
(let* ((st (plist-get range :start))
(beg (eglot--lsp-position-to-point st markers))
(end (eglot--lsp-position-to-point (plist-get range :end) markers)))
(cons beg end)))
(defun eglot--read-server (prompt &optional dont-if-just-the-one)
"Read a running Eglot server from minibuffer using PROMPT.
If DONT-IF-JUST-THE-ONE and there's only one server, don't prompt
@ -2078,9 +2087,6 @@ If it is activated, also signal textDocument/didOpen."
(package-delete existing t))
(package-install (cadr (assoc 'eglot package-archive-contents)))))
;;;###autoload
(define-obsolete-function-alias 'eglot-update 'eglot-upgrade-eglot "29.1")
(easy-menu-define eglot-menu nil "Eglot"
`("Eglot"
;; Commands for getting information and customization.
@ -2089,47 +2095,47 @@ If it is activated, also signal textDocument/didOpen."
;; xref like commands.
["Find definitions" xref-find-definitions
:help "Find definitions of identifier at point"
:active (eglot--server-capable :definitionProvider)]
:active (eglot-server-capable :definitionProvider)]
["Find references" xref-find-references
:help "Find references to identifier at point"
:active (eglot--server-capable :referencesProvider)]
:active (eglot-server-capable :referencesProvider)]
["Find symbols in workspace (apropos)" xref-find-apropos
:help "Find symbols matching a query"
:active (eglot--server-capable :workspaceSymbolProvider)]
:active (eglot-server-capable :workspaceSymbolProvider)]
["Find declaration" eglot-find-declaration
:help "Find declaration for identifier at point"
:active (eglot--server-capable :declarationProvider)]
:active (eglot-server-capable :declarationProvider)]
["Find implementation" eglot-find-implementation
:help "Find implementation for identifier at point"
:active (eglot--server-capable :implementationProvider)]
:active (eglot-server-capable :implementationProvider)]
["Find type definition" eglot-find-typeDefinition
:help "Find type definition for identifier at point"
:active (eglot--server-capable :typeDefinitionProvider)]
:active (eglot-server-capable :typeDefinitionProvider)]
"--"
;; LSP-related commands (mostly Eglot's own commands).
["Rename symbol" eglot-rename
:active (eglot--server-capable :renameProvider)]
:active (eglot-server-capable :renameProvider)]
["Format buffer" eglot-format-buffer
:active (eglot--server-capable :documentFormattingProvider)]
:active (eglot-server-capable :documentFormattingProvider)]
["Format active region" eglot-format
:active (and (region-active-p)
(eglot--server-capable :documentRangeFormattingProvider))]
(eglot-server-capable :documentRangeFormattingProvider))]
["Show Flymake diagnostics for buffer" flymake-show-buffer-diagnostics]
["Show Flymake diagnostics for project" flymake-show-project-diagnostics]
["Show Eldoc documentation at point" eldoc-doc-buffer]
"--"
["All possible code actions" eglot-code-actions
:active (eglot--server-capable :codeActionProvider)]
:active (eglot-server-capable :codeActionProvider)]
["Organize imports" eglot-code-action-organize-imports
:visible (eglot--server-capable :codeActionProvider)]
:visible (eglot-server-capable :codeActionProvider)]
["Extract" eglot-code-action-extract
:visible (eglot--server-capable :codeActionProvider)]
:visible (eglot-server-capable :codeActionProvider)]
["Inline" eglot-code-action-inline
:visible (eglot--server-capable :codeActionProvider)]
:visible (eglot-server-capable :codeActionProvider)]
["Rewrite" eglot-code-action-rewrite
:visible (eglot--server-capable :codeActionProvider)]
:visible (eglot-server-capable :codeActionProvider)]
["Quickfix" eglot-code-action-quickfix
:visible (eglot--server-capable :codeActionProvider)]))
:visible (eglot-server-capable :codeActionProvider)]))
(easy-menu-define eglot-server-menu nil "Monitor server communication"
'("Debugging the server communication"
@ -2323,7 +2329,7 @@ still unanswered LSP requests to the server\n")))
(t 'eglot-note)))
(mess (source code message)
(concat source (and code (format " [%s]" code)) ": " message)))
(if-let* ((path (expand-file-name (eglot--uri-to-path uri)))
(if-let* ((path (expand-file-name (eglot-uri-to-path uri)))
(buffer (find-buffer-visiting path)))
(with-current-buffer buffer
(cl-loop
@ -2335,7 +2341,7 @@ still unanswered LSP requests to the server\n")))
diag-spec
(setq message (mess source code message))
(pcase-let
((`(,beg . ,end) (eglot--range-region range)))
((`(,beg . ,end) (eglot-range-region range)))
;; Fallback to `flymake-diag-region' if server
;; botched the range
(when (= beg end)
@ -2427,7 +2433,7 @@ THINGS are either registrations or unregisterations (sic)."
(filename))
(cond
((eq external t) (browse-url uri))
((file-readable-p (setq filename (eglot--uri-to-path uri)))
((file-readable-p (setq filename (eglot-uri-to-path uri)))
;; Use run-with-timer to avoid nested client requests like the
;; "synchronous imenu" floated in bug#62116 presumably caused by
;; which-func-mode.
@ -2440,7 +2446,7 @@ THINGS are either registrations or unregisterations (sic)."
(select-frame-set-input-focus (selected-frame)))
((display-buffer (current-buffer))))
(when selection
(pcase-let ((`(,beg . ,end) (eglot--range-region selection)))
(pcase-let ((`(,beg . ,end) (eglot-range-region selection)))
;; FIXME: it is very naughty to use someone else's `--'
;; function, but `xref--goto-char' happens to have
;; exactly the semantics we want vis-a-vis widening.
@ -2451,7 +2457,7 @@ THINGS are either registrations or unregisterations (sic)."
(defun eglot--TextDocumentIdentifier ()
"Compute TextDocumentIdentifier object for current buffer."
`(:uri ,(eglot--path-to-uri (or buffer-file-name
`(:uri ,(eglot-path-to-uri (or buffer-file-name
(ignore-errors
(buffer-file-name
(buffer-base-buffer)))))))
@ -2492,7 +2498,7 @@ buffer."
(defun eglot--post-self-insert-hook ()
"Set `eglot--last-inserted-char', maybe call on-type-formatting."
(setq eglot--last-inserted-char last-command-event)
(let ((ot-provider (eglot--server-capable :documentOnTypeFormattingProvider)))
(let ((ot-provider (eglot-server-capable :documentOnTypeFormattingProvider)))
(when (and ot-provider
(ignore-errors ; github#906, some LS's send empty strings
(or (eq eglot--last-inserted-char
@ -2516,7 +2522,7 @@ buffer."
`(:context
,(if-let (trigger (and (characterp eglot--last-inserted-char)
(cl-find eglot--last-inserted-char
(eglot--server-capable :completionProvider
(eglot-server-capable :completionProvider
:triggerCharacters)
:key (lambda (str) (aref str 0))
:test #'char-equal)))
@ -2677,7 +2683,7 @@ When called interactively, use the currently active server"
(mapcar
(eglot--lambda ((ConfigurationItem) scopeUri section)
(cl-loop
with scope-uri-path = (and scopeUri (eglot--uri-to-path scopeUri))
with scope-uri-path = (and scopeUri (eglot-uri-to-path scopeUri))
for (wsection o)
on (eglot--workspace-configuration-plist server scope-uri-path)
by #'cddr
@ -2693,7 +2699,7 @@ When called interactively, use the currently active server"
"Send textDocument/didChange to server."
(when eglot--recent-changes
(let* ((server (eglot--current-server-or-lose))
(sync-capability (eglot--server-capable :textDocumentSync))
(sync-capability (eglot-server-capable :textDocumentSync))
(sync-kind (if (numberp sync-capability) sync-capability
(plist-get sync-capability :change)))
(full-sync-p (or (eq sync-kind 1)
@ -2738,9 +2744,9 @@ When called interactively, use the currently active server"
"Maybe send textDocument/willSave to server."
(let ((server (eglot--current-server-or-lose))
(params `(:reason 1 :textDocument ,(eglot--TextDocumentIdentifier))))
(when (eglot--server-capable :textDocumentSync :willSave)
(when (eglot-server-capable :textDocumentSync :willSave)
(jsonrpc-notify server :textDocument/willSave params))
(when (eglot--server-capable :textDocumentSync :willSaveWaitUntil)
(when (eglot-server-capable :textDocumentSync :willSaveWaitUntil)
(ignore-errors
(eglot--apply-text-edits
(eglot--request server :textDocument/willSaveWaitUntil params
@ -2749,7 +2755,7 @@ When called interactively, use the currently active server"
(defun eglot--signal-textDocument/didSave ()
"Maybe send textDocument/didSave to server."
(eglot--signal-textDocument/didChange)
(when (eglot--server-capable :textDocumentSync :save)
(when (eglot-server-capable :textDocumentSync :save)
(jsonrpc-notify
(eglot--current-server-or-lose)
:textDocument/didSave
@ -2808,12 +2814,12 @@ may be called multiple times (respecting the protocol of
"Like `xref-make-match' but with LSP's NAME, URI and RANGE.
Try to visit the target file for a richer summary line."
(pcase-let*
((file (eglot--uri-to-path uri))
((file (eglot-uri-to-path uri))
(visiting (or (find-buffer-visiting file)
(gethash uri eglot--temp-location-buffers)))
(collect (lambda ()
(eglot--widening
(pcase-let* ((`(,beg . ,end) (eglot--range-region range))
(pcase-let* ((`(,beg . ,end) (eglot-range-region range))
(bol (progn (goto-char beg) (eglot--bol)))
(substring (buffer-substring bol (line-end-position)))
(hi-beg (- beg bol))
@ -2844,7 +2850,7 @@ Try to visit the target file for a richer summary line."
"Ask for :workspace/symbol on PAT, return list of formatted strings.
If BUFFER, switch to it before."
(with-current-buffer (or buffer (current-buffer))
(eglot--server-capable-or-lose :workspaceSymbolProvider)
(eglot-server-capable-or-lose :workspaceSymbolProvider)
(mapcar
(lambda (wss)
(eglot--dbind ((WorkspaceSymbol) name containerName kind) wss
@ -2906,7 +2912,7 @@ If BUFFER, switch to it before."
(cl-defun eglot--lsp-xrefs-for-method (method &key extra-params capability)
"Make `xref''s for METHOD, EXTRA-PARAMS, check CAPABILITY."
(eglot--server-capable-or-lose
(eglot-server-capable-or-lose
(or capability
(intern
(format ":%sProvider"
@ -2970,7 +2976,7 @@ If BUFFER, switch to it before."
:textDocument/references :extra-params `(:context (:includeDeclaration t)))))
(cl-defmethod xref-backend-apropos ((_backend (eql eglot)) pattern)
(when (eglot--server-capable :workspaceSymbolProvider)
(when (eglot-server-capable :workspaceSymbolProvider)
(eglot--collecting-xrefs (collect)
(mapc
(eglot--lambda ((SymbolInformation) name location)
@ -3008,7 +3014,7 @@ for which LSP on-type-formatting should be requested."
:end (eglot--pos-to-lsp-position end)))))
(t
'(:textDocument/formatting :documentFormattingProvider nil)))))
(eglot--server-capable-or-lose cap)
(eglot-server-capable-or-lose cap)
(eglot--apply-text-edits
(eglot--request
(eglot--current-server-or-lose)
@ -3033,7 +3039,7 @@ for which LSP on-type-formatting should be requested."
(defun eglot-completion-at-point ()
"Eglot's `completion-at-point' function."
;; Commit logs for this function help understand what's going on.
(when-let (completion-capability (eglot--server-capable :completionProvider))
(when-let (completion-capability (eglot-server-capable :completionProvider))
(let* ((server (eglot--current-server-or-lose))
(sort-completions
(lambda (completions)
@ -3096,7 +3102,7 @@ for which LSP on-type-formatting should be requested."
(lambda (lsp-comp)
(or (gethash lsp-comp resolved)
(setf (gethash lsp-comp resolved)
(if (and (eglot--server-capable :completionProvider
(if (and (eglot-server-capable :completionProvider
:resolveProvider)
(plist-get lsp-comp :data))
(eglot--request server :completionItem/resolve
@ -3224,7 +3230,7 @@ for which LSP on-type-formatting should be requested."
(delete-region orig-pos (point))
(eglot--dbind ((TextEdit) range newText) textEdit
(pcase-let ((`(,beg . ,end)
(eglot--range-region range)))
(eglot-range-region range)))
(delete-region beg end)
(goto-char beg)
(funcall (or snippet-fn #'insert) newText))))
@ -3307,7 +3313,7 @@ for which LSP on-type-formatting should be requested."
(defun eglot-signature-eldoc-function (cb)
"A member of `eldoc-documentation-functions', for signatures."
(when (eglot--server-capable :signatureHelpProvider)
(when (eglot-server-capable :signatureHelpProvider)
(let ((buf (current-buffer)))
(jsonrpc-async-request
(eglot--current-server-or-lose)
@ -3331,7 +3337,7 @@ for which LSP on-type-formatting should be requested."
(defun eglot-hover-eldoc-function (cb)
"A member of `eldoc-documentation-functions', for hover."
(when (eglot--server-capable :hoverProvider)
(when (eglot-server-capable :hoverProvider)
(let ((buf (current-buffer)))
(jsonrpc-async-request
(eglot--current-server-or-lose)
@ -3353,7 +3359,7 @@ for which LSP on-type-formatting should be requested."
;; FIXME: Obviously, this is just piggy backing on eldoc's calls for
;; convenience, as shown by the fact that we just ignore cb.
(let ((buf (current-buffer)))
(when (eglot--server-capable :documentHighlightProvider)
(when (eglot-server-capable :documentHighlightProvider)
(jsonrpc-async-request
(eglot--current-server-or-lose)
:textDocument/documentHighlight (eglot--TextDocumentPositionParams)
@ -3365,7 +3371,7 @@ for which LSP on-type-formatting should be requested."
(mapcar
(eglot--lambda ((DocumentHighlight) range)
(pcase-let ((`(,beg . ,end)
(eglot--range-region range)))
(eglot-range-region range)))
(let ((ov (make-overlay beg end)))
(overlay-put ov 'face 'eglot-highlight-symbol-face)
(overlay-put ov 'modification-hooks
@ -3385,7 +3391,7 @@ for which LSP on-type-formatting should be requested."
(pcase-lambda (`(,container . ,objs))
(let ((elems (mapcar
(eglot--lambda ((SymbolInformation) kind name location)
(let ((reg (eglot--range-region
(let ((reg (eglot-range-region
(plist-get location :range)))
(kind (alist-get kind eglot--symbol-kind-names)))
(cons (propertize name
@ -3401,7 +3407,7 @@ for which LSP on-type-formatting should be requested."
(defun eglot--imenu-DocumentSymbol (res)
"Compute `imenu--index-alist' for RES vector of DocumentSymbol."
(cl-labels ((dfs (&key name children range kind &allow-other-keys)
(let* ((reg (eglot--range-region range))
(let* ((reg (eglot-range-region range))
(kind (alist-get kind eglot--symbol-kind-names))
(name (propertize name
'breadcrumb-region reg
@ -3415,7 +3421,7 @@ for which LSP on-type-formatting should be requested."
(cl-defun eglot-imenu ()
"Eglot's `imenu-create-index-function'.
Returns a list as described in docstring of `imenu--index-alist'."
(unless (eglot--server-capable :documentSymbolProvider)
(unless (eglot-server-capable :documentSymbolProvider)
(cl-return-from eglot-imenu))
(let* ((res (eglot--request (eglot--current-server-or-lose)
:textDocument/documentSymbol
@ -3457,7 +3463,7 @@ If SILENT, don't echo progress in mode-line."
(when reporter
(eglot--reporter-update reporter (cl-incf done))))))))
(mapcar (eglot--lambda ((TextEdit) range newText)
(cons newText (eglot--range-region range 'markers)))
(cons newText (eglot-range-region range 'markers)))
(reverse edits)))
(undo-amalgamate-change-group change-group)
(when reporter
@ -3521,14 +3527,14 @@ edit proposed by the server."
(mapcar (eglot--lambda ((TextDocumentEdit) textDocument edits)
(eglot--dbind ((VersionedTextDocumentIdentifier) uri version)
textDocument
(list (eglot--uri-to-path uri) edits version)))
(list (eglot-uri-to-path uri) edits version)))
documentChanges)))
(unless (and changes documentChanges)
;; We don't want double edits, and some servers send both
;; changes and documentChanges. This unless ensures that we
;; prefer documentChanges over changes.
(cl-loop for (uri edits) on changes by #'cddr
do (push (list (eglot--uri-to-path uri) edits) prepared)))
do (push (list (eglot-uri-to-path uri) edits) prepared)))
(cl-flet ((notevery-visited-p ()
(cl-notevery #'find-buffer-visiting
(mapcar #'car prepared)))
@ -3566,7 +3572,7 @@ edit proposed by the server."
"unknown symbol"))
nil nil nil nil
(symbol-name (symbol-at-point)))))
(eglot--server-capable-or-lose :renameProvider)
(eglot-server-capable-or-lose :renameProvider)
(eglot--apply-workspace-edit
(eglot--request (eglot--current-server-or-lose)
:textDocument/rename `(,@(eglot--TextDocumentPositionParams)
@ -3593,7 +3599,7 @@ at point. With prefix argument, prompt for ACTION-KIND."
'("quickfix" "refactor.extract" "refactor.inline"
"refactor.rewrite" "source.organizeImports")))
t))
(eglot--server-capable-or-lose :codeActionProvider)
(eglot-server-capable-or-lose :codeActionProvider)
(let* ((server (eglot--current-server-or-lose))
(actions
(eglot--request
@ -3693,7 +3699,7 @@ at point. With prefix argument, prompt for ACTION-KIND."
(funcall glob file))))
(jsonrpc-notify
server :workspace/didChangeWatchedFiles
`(:changes ,(vector `(:uri ,(eglot--path-to-uri file)
`(:changes ,(vector `(:uri ,(eglot-path-to-uri file)
:type ,action-type))))
(when (and (eq action 'created)
(file-directory-p file))
@ -3960,7 +3966,7 @@ If NOERROR, return predicate, else erroring function."
"Minor mode for annotating buffers with LSP server's inlay hints."
:global nil
(cond (eglot-inlay-hints-mode
(if (eglot--server-capable :inlayHintProvider)
(if (eglot-server-capable :inlayHintProvider)
(jit-lock-register #'eglot--update-hints 'contextual)
(eglot-inlay-hints-mode -1)))
(t
@ -3987,11 +3993,7 @@ If NOERROR, return predicate, else erroring function."
"https://github.com/joaotavora/eglot/issues/%s"
"https://debbugs.gnu.org/%s")
(match-string 3))))
;;; Obsolete
;;;
(make-obsolete-variable 'eglot--managed-mode-hook
'eglot-managed-mode-hook "1.6")
(provide 'eglot)

5
lisp/progmodes/idlwave.el
View file

@ -8750,11 +8750,12 @@ This expects NAME TYPE IDLWAVE-TWIN-CLASS to be bound to the right values."
(defun idlwave-count-eq (elt list)
"How often is ELT in LIST?"
(length (delq nil (mapcar (lambda (x) (eq x elt)) list))))
(declare (obsolete nil "30.1"))
(seq-count (lambda (x) (eq x elt)) list))
(defun idlwave-count-memq (elt alist)
"How often is ELT a key in ALIST?"
(length (delq nil (mapcar (lambda (x) (eq (car x) elt)) alist))))
(seq-count (lambda (x) (eq (car x) elt)) alist))
(defun idlwave-syslib-p (file)
"Non-nil if FILE is in the system library."

2
test/lisp/autorevert-tests.el
View file

@ -257,7 +257,7 @@ This expects `auto-revert--messages' to be bound by
;; Repeated unpredictable failures, bug#32645.
:tags '(:unstable)
;; Unlikely to be hydra-specific?
;; (skip-unless (not (getenv "EMACS_HYDRA_CI")))
;; (skip-when (getenv "EMACS_HYDRA_CI"))
(with-auto-revert-test
(ert-with-temp-file tmpfile
(let (;; Try to catch bug#32645.

4
test/lisp/emacs-lisp/benchmark-tests.el
View file

@ -25,8 +25,8 @@
(ert-deftest benchmark-tests ()
;; Avoid fork failures on Cygwin. See bug#62450 and etc/PROBLEMS
;; ("Fork failures in a build with native compilation").
(skip-unless (not (and (eq system-type 'cygwin)
(featurep 'native-compile))))
(skip-when (and (eq system-type 'cygwin)
(featurep 'native-compile)))
(let (str t-long t-short m)
(should (consp (benchmark-run nil (setq m (1+ 0)))))
(should (consp (benchmark-run 1 (setq m (1+ 0)))))

14
test/lisp/emacs-lisp/ert-tests.el
View file

@ -304,6 +304,20 @@ failed or if there was a problem."
(cl-macrolet ((test () (error "Foo")))
(should-error (test))))
(ert-deftest ert-test-skip-when ()
;; Don't skip.
(let ((test (make-ert-test :body (lambda () (skip-when nil)))))
(let ((result (ert-run-test test)))
(should (ert-test-passed-p result))))
;; Skip.
(let ((test (make-ert-test :body (lambda () (skip-when t)))))
(let ((result (ert-run-test test)))
(should (ert-test-skipped-p result))))
;; Skip in case of error.
(let ((test (make-ert-test :body (lambda () (skip-when (error "Foo"))))))
(let ((result (ert-run-test test)))
(should (ert-test-skipped-p result)))))
(ert-deftest ert-test-skip-unless ()
;; Don't skip.
(let ((test (make-ert-test :body (lambda () (skip-unless t)))))

2
test/lisp/emacs-lisp/find-func-tests.el
View file

@ -32,7 +32,7 @@
(ert-deftest find-func-tests--library-completion () ;bug#43393
;; FIXME: How can we make this work in batch (see also
;; `mule-cmds--test-universal-coding-system-argument')?
;; (skip-unless (not noninteractive))
;; (skip-when noninteractive)
;; Check that `partial-completion' works when completing library names.
(should (equal "org/org"
(ert-simulate-keys

2
test/lisp/eshell/esh-proc-tests.el
View file

@ -281,7 +281,7 @@ prompt. See bug#54136."
(executable-find "sleep")))
;; This test doesn't work on EMBA with AOT nativecomp, but works
;; fine elsewhere.
(skip-unless (not (getenv "EMACS_EMBA_CI")))
(skip-when (getenv "EMACS_EMBA_CI"))
(with-temp-eshell
(eshell-insert-command
(concat "sh -c 'while true; do echo y; sleep 1; done' | "

2
test/lisp/filenotify-tests.el
View file

@ -1583,7 +1583,7 @@ the file watch."
:tags '(:expensive-test)
(skip-unless (file-notify--test-local-enabled))
;; This test does not work for kqueue (yet).
(skip-unless (not (string-equal (file-notify--test-library) "kqueue")))
(skip-when (string-equal (file-notify--test-library) "kqueue"))
(setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
file-notify--test-tmpfile1 (file-notify--test-make-temp-name))

2
test/lisp/ibuffer-tests.el
View file

@ -34,7 +34,7 @@
(ert-deftest ibuffer-0autoload () ; sort first
"Tests to see whether ibuffer has been autoloaded"
(skip-unless (not (featurep 'ibuf-ext)))
(skip-when (featurep 'ibuf-ext))
(should
(fboundp 'ibuffer-mark-unsaved-buffers))
(should

4
test/lisp/international/ucs-normalize-tests.el
View file

@ -255,8 +255,8 @@ Must be called with `ucs-normalize-tests--norm-buf' as current buffer."
(ert-deftest ucs-normalize-part1 ()
:tags '(:expensive-test)
(skip-unless (not (or (getenv "EMACS_HYDRA_CI")
(getenv "EMACS_EMBA_CI")))) ; SLOW ~ 1800s
(skip-when (or (getenv "EMACS_HYDRA_CI")
(getenv "EMACS_EMBA_CI"))) ; SLOW ~ 1800s
;; This takes a long time, so make sure we're compiled.
(dolist (fun '(ucs-normalize-tests--part1-rule2
ucs-normalize-tests--rule1-failing-for-partX

20
test/lisp/net/network-stream-tests.el
View file

@ -236,7 +236,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(skip-unless (not (eq (process-status proc) 'connect)))
(skip-when (eq (process-status proc) 'connect))
(with-current-buffer (process-buffer proc)
(process-send-string proc "echo foo")
(sleep-for 0.1)
@ -323,7 +323,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(skip-unless (not (eq (process-status proc) 'connect))))
(skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@ -336,7 +336,7 @@
(ert-deftest connect-to-tls-ipv6-nowait ()
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
(skip-unless (not (eq system-type 'windows-nt)))
(skip-when (eq system-type 'windows-nt))
(skip-unless (featurep 'make-network-process '(:family ipv6)))
(let ((server (make-tls-server 44333))
(times 0)
@ -368,7 +368,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(skip-unless (not (eq (process-status proc) 'connect))))
(skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@ -403,7 +403,7 @@
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(should proc)
(skip-unless (not (eq (process-status proc) 'connect))))
(skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@ -446,7 +446,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(skip-unless (not (eq (process-status proc) 'connect))))
(skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@ -484,7 +484,7 @@
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(should proc)
(skip-unless (not (eq (process-status proc) 'connect))))
(skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@ -523,7 +523,7 @@
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(should proc)
(skip-unless (not (eq (process-status proc) 'connect))))
(skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@ -673,7 +673,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(skip-unless (not (eq (process-status proc) 'connect))))
(skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@ -712,7 +712,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(skip-unless (not (eq (process-status proc) 'connect))))
(skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))

6
test/lisp/progmodes/cperl-mode-tests.el
View file

@ -892,8 +892,8 @@ without a statement terminator on the same line does not loop
forever. The test starts an asynchronous Emacs batch process
under timeout control."
:tags '(:expensive-test)
(skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; FIXME times out
(skip-unless (not (< emacs-major-version 28))) ; times out in older Emacsen
(skip-when (getenv "EMACS_HYDRA_CI")) ; FIXME times out
(skip-when (< emacs-major-version 28)) ; times out in older Emacsen
(skip-unless (eq cperl-test-mode #'cperl-mode))
(let* ((emacs (concat invocation-directory invocation-name))
(test-function 'cperl-test--run-bug-10483)
@ -1242,7 +1242,7 @@ however, must not happen when the keyword occurs in a variable
\"$else\" or \"$continue\"."
(skip-unless (eq cperl-test-mode #'cperl-mode))
;; `self-insert-command' takes a second argument only since Emacs 27
(skip-unless (not (< emacs-major-version 27)))
(skip-when (< emacs-major-version 27))
(with-temp-buffer
(setq cperl-electric-keywords t)
(cperl-mode)

8
test/lisp/progmodes/elisp-mode-tests.el
View file

@ -128,7 +128,7 @@
(ert-deftest eval-last-sexp-print-format-sym-echo ()
;; We can only check the echo area when running interactive.
(skip-unless (not noninteractive))
(skip-when noninteractive)
(with-temp-buffer
(let ((current-prefix-arg nil))
(erase-buffer) (insert "t") (message nil)
@ -147,7 +147,7 @@
(should (equal (buffer-string) "?A65 (#o101, #x41, ?A)")))))
(ert-deftest eval-last-sexp-print-format-small-int-echo ()
(skip-unless (not noninteractive))
(skip-when noninteractive)
(with-temp-buffer
(let ((current-prefix-arg nil))
(erase-buffer) (insert "?A") (message nil)
@ -171,7 +171,7 @@
(should (equal (buffer-string) "?B66 (#o102, #x42, ?B)"))))))
(ert-deftest eval-last-sexp-print-format-large-int-echo ()
(skip-unless (not noninteractive))
(skip-when noninteractive)
(with-temp-buffer
(let ((eval-expression-print-maximum-character ?A))
(let ((current-prefix-arg nil))
@ -186,7 +186,7 @@
;;; eval-defun
(ert-deftest eval-defun-prints-edebug-when-instrumented ()
(skip-unless (not noninteractive))
(skip-when noninteractive)
(with-temp-buffer
(let ((current-prefix-arg '(4)))
(erase-buffer) (insert "(defun foo ())") (message nil)

2
test/lisp/progmodes/python-tests.el
View file

@ -4918,7 +4918,7 @@ import abc
;; Skip the test on macOS, since the standard Python installation uses
;; libedit rather than readline which confuses the running of an inferior
;; interpreter in this case (see bug#59477 and bug#25753).
(skip-unless (not (eq system-type 'darwin)))
(skip-when (eq system-type 'darwin))
(trace-function 'python-shell-output-filter)
(python-tests-with-temp-buffer-with-shell
"

20
test/lisp/shadowfile-tests.el
View file

@ -101,7 +101,7 @@ Per definition, all files are identical on the different hosts of
a cluster (or site). This is not tested here; it must be
guaranteed by the originator of a cluster definition."
:tags '(:expensive-test)
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((text-quoting-style 'grave) ;; We inspect the *Messages* buffer!
@ -219,7 +219,7 @@ guaranteed by the originator of a cluster definition."
Per definition, all files are identical on the different hosts of
a cluster (or site). This is not tested here; it must be
guaranteed by the originator of a cluster definition."
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@ -320,7 +320,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test02-files ()
"Check file manipulation functions."
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@ -391,7 +391,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test03-expand-cluster-in-file-name ()
"Check canonical file name of a cluster or site."
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@ -456,7 +456,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test04-contract-file-name ()
"Check canonical file name of a cluster or site."
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@ -511,7 +511,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test05-file-match ()
"Check `shadow-same-site' and `shadow-file-match'."
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@ -563,7 +563,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test06-literal-groups ()
"Check literal group definitions."
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@ -648,7 +648,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test07-regexp-groups ()
"Check regexp group definitions."
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@ -710,7 +710,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test08-shadow-todo ()
"Check that needed shadows are added to todo."
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(skip-unless (file-writable-p ert-remote-temporary-file-directory))
@ -855,7 +855,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test09-shadow-copy-files ()
"Check that needed shadow files are copied."
:tags '(:expensive-test)
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(skip-unless (file-writable-p ert-remote-temporary-file-directory))

6
test/lisp/simple-tests.el
View file

@ -742,7 +742,7 @@ See Bug#21722."
(ert-deftest eval-expression-print-format-sym-echo ()
;; We can only check the echo area when running interactive.
(skip-unless (not noninteractive))
(skip-when noninteractive)
(with-temp-buffer
(cl-letf (((symbol-function 'read--expression) (lambda (&rest _) t)))
(let ((current-prefix-arg nil))
@ -763,7 +763,7 @@ See Bug#21722."
(should (equal (buffer-string) "65 (#o101, #x41, ?A)"))))))
(ert-deftest eval-expression-print-format-small-int-echo ()
(skip-unless (not noninteractive))
(skip-when noninteractive)
(with-temp-buffer
(cl-letf (((symbol-function 'read--expression) (lambda (&rest _) ?A)))
(let ((current-prefix-arg nil))
@ -789,7 +789,7 @@ See Bug#21722."
(should (equal (buffer-string) "66 (#o102, #x42, ?B)"))))))
(ert-deftest eval-expression-print-format-large-int-echo ()
(skip-unless (not noninteractive))
(skip-when noninteractive)
(with-temp-buffer
(cl-letf (((symbol-function 'read--expression) (lambda (&rest _) ?B))
(eval-expression-print-maximum-character ?A))

20
test/lisp/term-tests.el
View file

@ -110,7 +110,7 @@
(buffer-substring (point-min) (point-max))))))
(ert-deftest term-simple-lines ()
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(let ((str "\
first line\r
next line\r\n"))
@ -118,14 +118,14 @@ next line\r\n"))
(string-replace "\r" "" str)))))
(ert-deftest term-carriage-return ()
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(let ((str "\
first line\r_next line\r\n"))
(should (equal (term-test-screen-from-input 40 12 str)
"_next line\n"))))
(ert-deftest term-line-wrap ()
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(should (string-match-p
;; Don't be strict about trailing whitespace.
"\\`a\\{40\\}\na\\{20\\} *\\'"
@ -137,7 +137,7 @@ first line\r_next line\r\n"))
(list str str))))))
(ert-deftest term-colors ()
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(pcase-dolist (`(,str ,expected) ansi-test-strings)
(let ((result (term-test-screen-from-input 40 12 str)))
(should (equal result expected))
@ -145,7 +145,7 @@ first line\r_next line\r\n"))
(text-properties-at 0 expected))))))
(ert-deftest term-colors-bold-is-bright ()
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(let ((ansi-color-bold-is-bright t))
(pcase-dolist (`(,str ,expected ,bright-expected) ansi-test-strings)
(let ((expected (or bright-expected expected))
@ -155,7 +155,7 @@ first line\r_next line\r\n"))
(text-properties-at 0 expected)))))))
(ert-deftest term-cursor-movement ()
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
;; Absolute positioning.
(should (equal "ab\ncd"
(term-test-screen-from-input
@ -186,7 +186,7 @@ first line\r_next line\r\n"))
"\e[D\e[Da")))))
(ert-deftest term-scrolling-region ()
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(should (equal "\
line3
line4
@ -338,7 +338,7 @@ line6\r
line7")))))
(ert-deftest term-set-directory ()
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(let ((term-ansi-at-user (user-real-login-name)))
(should (equal (term-test-screen-from-input
40 12 "\eAnSiTc /foo/\n" 'default-directory)
@ -354,7 +354,7 @@ A real-life example is the default zsh prompt which writes spaces
to the end of line (triggering line-wrapping state), and then
sends a carriage return followed by another space to overwrite
the first character of the line."
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(let* ((width 10)
(strs (list "x" (make-string (1- width) ?_)
"\r_")))
@ -364,7 +364,7 @@ the first character of the line."
(ert-deftest term-to-margin ()
"Test cursor movement at the scroll margin.
This is a reduced example from GNU nano's initial screen."
(skip-unless (not (memq system-type '(windows-nt ms-dos))))
(skip-when (memq system-type '(windows-nt ms-dos)))
(let* ((width 10)
(x (make-string width ?x))
(y (make-string width ?y)))

2
test/lisp/thread-tests.el
View file

@ -88,7 +88,7 @@
(ert-deftest thread-tests-list-threads-error-when-not-configured ()
"Signal an error running `list-threads' if threads are not configured."
(skip-unless (not (featurep 'threads)))
(skip-when (featurep 'threads))
(should-error (list-threads)))
(provide 'thread-tests)

4
test/lisp/vc/vc-tests.el
View file

@ -781,7 +781,7 @@ This checks also `vc-backend' and `vc-responsible-backend'."
;; CVS calls vc-delete-file, which insists on prompting
;; "Really want to delete ...?", and `vc-mtn.el' does not implement
;; `delete-file' at all.
(skip-unless (not (memq ',backend '(CVS Mtn))))
(skip-when (memq ',backend '(CVS Mtn)))
(vc-test--rename-file ',backend))
(ert-deftest
@ -796,7 +796,7 @@ This checks also `vc-backend' and `vc-responsible-backend'."
(format "vc-test-%s01-register" backend-string))))))
;; `vc-mtn.el' gives me:
;; "Failed (status 1): mtn commit -m Testing vc-version-diff\n\n foo"
(skip-unless (not (memq ',backend '(Mtn))))
(skip-when (memq ',backend '(Mtn)))
(vc-test--version-diff ',backend))
))))

10
test/manual/scroll-tests.el
View file

@ -80,25 +80,25 @@
,@body)))
(ert-deftest scroll-tests-scroll-margin-0 ()
(skip-unless (not noninteractive))
(skip-when noninteractive)
(scroll-tests-with-buffer-window
(scroll-tests-up-and-down 0)))
(ert-deftest scroll-tests-scroll-margin-negative ()
"A negative `scroll-margin' should be the same as 0."
(skip-unless (not noninteractive))
(skip-when noninteractive)
(scroll-tests-with-buffer-window
(scroll-tests-up-and-down -10 0)))
(ert-deftest scroll-tests-scroll-margin-max ()
(skip-unless (not noninteractive))
(skip-when noninteractive)
(scroll-tests-with-buffer-window
(let ((max-margin (/ (window-text-height) 4)))
(scroll-tests-up-and-down max-margin))))
(ert-deftest scroll-tests-scroll-margin-over-max ()
"A `scroll-margin' more than max should be the same as max."
(skip-unless (not noninteractive))
(skip-when noninteractive)
(scroll-tests-with-buffer-window 7
(let ((max-margin (/ (window-text-height) 4)))
(scroll-tests-up-and-down (+ max-margin 1) max-margin)
@ -155,7 +155,7 @@ middle of the window."
(should (scroll-tests--point-in-middle-of-window-p)))))
(ert-deftest scroll-tests-scroll-margin-whole-window ()
(skip-unless (not noninteractive))
(skip-when noninteractive)
(scroll-tests--scroll-margin-whole-window))
(ert-deftest scroll-tests-scroll-margin-whole-window-line-spacing ()

2
test/misc/test-custom-libs.el
View file

@ -39,7 +39,7 @@
:tags '(:expensive-test)
:expected-result :failed ; FIXME: See above.
;; This test is very slow, and IMO not worth the time it takes.
(skip-unless (not (getenv "EMACS_HYDRA_CI")))
(skip-when (getenv "EMACS_HYDRA_CI"))
(skip-unless (file-readable-p custom-test-admin-cus-test))
(load custom-test-admin-cus-test)
(cus-test-libs t)

2
test/src/emacs-module-tests.el
View file

@ -457,7 +457,7 @@ See Bug#36226."
(ert-deftest module/async-pipe ()
"Check that writing data from another thread works."
(skip-unless (not (eq system-type 'windows-nt))) ; FIXME!
(skip-when (eq system-type 'windows-nt)) ; FIXME!
(with-temp-buffer
(let ((process (make-pipe-process :name "module/async-pipe"
:buffer (current-buffer)

2
test/src/fileio-tests.el
View file

@ -50,7 +50,7 @@ Also check that an encoding error can appear in a symlink."
;; Some Windows versions don't support symlinks, and those which do
;; will pop up UAC elevation prompts, so we disable this test on
;; MS-Windows.
(skip-unless (not (eq system-type 'windows-nt)))
(skip-when (eq system-type 'windows-nt))
(should (equal nil (fileio-tests--symlink-failure))))
(ert-deftest fileio-tests--directory-file-name ()

10
test/src/filelock-tests.el
View file

@ -109,7 +109,7 @@ the case)."
(ert-deftest filelock-tests-lock-spoiled ()
"Check `lock-buffer'."
(skip-unless (not (eq system-type 'ms-dos))) ; no filelock support
(skip-when (eq system-type 'ms-dos)) ; no filelock support
(filelock-tests--fixture
(filelock-tests--spoil-lock-file buffer-file-truename)
;; FIXME: errors when locking a file are ignored; should they be?
@ -119,7 +119,7 @@ the case)."
(ert-deftest filelock-tests-file-locked-p-spoiled ()
"Check that `file-locked-p' fails if the lockfile is \"spoiled\"."
(skip-unless (not (eq system-type 'ms-dos))) ; no filelock support
(skip-when (eq system-type 'ms-dos)) ; no filelock support
(filelock-tests--fixture
(filelock-tests--spoil-lock-file buffer-file-truename)
(let ((err (should-error (file-locked-p (buffer-file-name)))))
@ -130,7 +130,7 @@ the case)."
(ert-deftest filelock-tests-unlock-spoiled ()
"Check that `unlock-buffer' fails if the lockfile is \"spoiled\"."
(skip-unless (not (eq system-type 'ms-dos))) ; no filelock support
(skip-when (eq system-type 'ms-dos)) ; no filelock support
(filelock-tests--fixture
;; Set the buffer modified with file locking temporarily disabled.
(let ((create-lockfiles nil))
@ -150,7 +150,7 @@ the case)."
(ert-deftest filelock-tests-kill-buffer-spoiled ()
"Check that `kill-buffer' fails if a lockfile is \"spoiled\"."
(skip-unless (not (eq system-type 'ms-dos))) ; no filelock support
(skip-when (eq system-type 'ms-dos)) ; no filelock support
(filelock-tests--fixture
;; Set the buffer modified with file locking temporarily disabled.
(let ((create-lockfiles nil))
@ -176,7 +176,7 @@ the case)."
(ert-deftest filelock-tests-detect-external-change ()
"Check that an external file modification is reported."
(skip-unless (not (eq system-type 'ms-dos))) ; no filelock support
(skip-when (eq system-type 'ms-dos)) ; no filelock support
(skip-unless (executable-find "touch"))
(skip-unless (executable-find "echo"))
(dolist (cl '(t nil))

6
test/src/image-tests.el
View file

@ -44,15 +44,15 @@
(xpm . ,(find-image '((:file "splash.xpm" :type xpm))))))
(ert-deftest image-tests-image-size/error-on-nongraphical-display ()
(skip-unless (not (display-images-p)))
(skip-when (display-images-p))
(should-error (image-size 'invalid-spec)))
(ert-deftest image-tests-image-mask-p/error-on-nongraphical-display ()
(skip-unless (not (display-images-p)))
(skip-when (display-images-p))
(should-error (image-mask-p (cdr (assq 'xpm image-tests--images)))))
(ert-deftest image-tests-image-metadata/error-on-nongraphical-display ()
(skip-unless (not (display-images-p)))
(skip-when (display-images-p))
(should-error (image-metadata (cdr (assq 'xpm image-tests--images)))))
(ert-deftest image-tests-imagemagick-types ()

6
test/src/process-tests.el
View file

@ -231,7 +231,7 @@ process to complete."
(with-timeout (60 (ert-fail "Test timed out"))
;; Frequent random (?) failures on hydra.nixos.org, with no process output.
;; Maybe this test should be tagged unstable? See bug#31214.
(skip-unless (not (getenv "EMACS_HYDRA_CI")))
(skip-when (getenv "EMACS_HYDRA_CI"))
(with-temp-buffer
(let ((process (make-process
:name "mix-stderr"
@ -723,7 +723,7 @@ FD_SETSIZE file descriptors (Bug#24325)."
(skip-unless (featurep 'make-network-process '(:server t)))
(skip-unless (featurep 'make-network-process '(:family local)))
;; Avoid hang due to connect/accept handshake on Cygwin (bug#49496).
(skip-unless (not (eq system-type 'cygwin)))
(skip-when (eq system-type 'cygwin))
(with-timeout (60 (ert-fail "Test timed out"))
(ert-with-temp-directory directory
(process-tests--with-processes processes
@ -763,7 +763,7 @@ FD_SETSIZE file descriptors (Bug#24325)."
"Check that Emacs doesn't crash when trying to use more than
FD_SETSIZE file descriptors (Bug#24325)."
;; This test cannot be run if PTYs aren't supported.
(skip-unless (not (eq system-type 'windows-nt)))
(skip-when (eq system-type 'windows-nt))
(with-timeout (60 (ert-fail "Test timed out"))
(process-tests--with-processes processes
;; In order to use `make-serial-process', we need to create some