1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
|
;;; filelock-tests.el --- test file locking -*- lexical-binding: t; -*-
;; Copyright (C) 2021-2024 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This file tests code in src/filelock.c and, to some extent, the
;; related code in src/fileio.c.
;;
;; See also (info "(emacs)Interlocking") and (info "(elisp)File Locks")
;;; Code:
(require 'cl-lib)
(require 'ert)
(require 'ert-x)
(require 'seq)
(defmacro filelock-tests--fixture (&rest body)
"Call BODY under a test fixture.
Create a test directory and a buffer whose `buffer-file-name' and
`buffer-file-truename' are a file within it, then call BODY.
Finally, delete the buffer and the test directory."
(declare (debug (body)))
`(ert-with-temp-directory temp-dir
(let ((name
;; Use file-truename for when 'temporary-file-directory'
;; is a symlink, to make sure 'buffer-file-name' is set
;; below to a real existing file.
(file-truename (concat (file-name-as-directory temp-dir)
"userfile")))
(create-lockfiles t))
(with-temp-buffer
(setq buffer-file-name name
buffer-file-truename name)
(unwind-protect
(save-current-buffer
,@body)
;; Set `buffer-file-truename' nil to prevent unlocking,
;; which might prompt the user and/or signal errors.
(setq buffer-file-name nil
buffer-file-truename nil))))))
(defun filelock-tests--make-lock-name (file-name)
"Return the lock file name for FILE-NAME.
Equivalent logic in Emacs proper is implemented in C and
unavailable to Lisp."
(concat (file-name-directory (expand-file-name file-name))
".#"
(file-name-nondirectory file-name)))
(defun filelock-tests--spoil-lock-file (file-name)
"Spoil the lock file for FILE-NAME.
Cause Emacs to report errors for various file locking operations
on FILE-NAME going forward. Create a file that is incompatible
with Emacs' file locking protocol, but uses the same name as
FILE-NAME's lock file. A directory file is used, which is
portable in practice."
(make-directory (filelock-tests--make-lock-name file-name)))
(defun filelock-tests--unspoil-lock-file (file-name)
"Remove the lock file spoiler for FILE-NAME.
See `filelock-tests--spoil-lock-file'."
(delete-directory (filelock-tests--make-lock-name file-name) t))
(defun filelock-tests--should-be-locked ()
"Abort the current test if the current buffer is not locked.
Exception: on systems without lock file support, aborts the
current test if the current file is locked (which should never
the case)."
(if (eq system-type 'ms-dos)
(should-not (file-locked-p buffer-file-truename))
(should (file-locked-p buffer-file-truename))))
(ert-deftest filelock-tests-lock-unlock-no-errors ()
"Check that locking and unlocking works without error."
(filelock-tests--fixture
(should-not (file-locked-p (buffer-file-name)))
;; Inserting text should lock the buffer's file.
(insert "this locks the buffer's file")
(filelock-tests--should-be-locked)
(unlock-buffer)
(set-buffer-modified-p nil)
(should-not (file-locked-p (buffer-file-name)))
;; `set-buffer-modified-p' should lock the buffer's file.
(set-buffer-modified-p t)
(filelock-tests--should-be-locked)
(unlock-buffer)
(should-not (file-locked-p (buffer-file-name)))
(should-not (file-locked-p (buffer-file-name)))))
(ert-deftest filelock-tests-lock-spoiled ()
"Check `lock-buffer'."
(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?
(set-buffer-modified-p t)
(filelock-tests--unspoil-lock-file buffer-file-truename)
(should-not (file-locked-p buffer-file-truename))))
(ert-deftest filelock-tests-file-locked-p-spoiled ()
"Check that `file-locked-p' fails if the lockfile is \"spoiled\"."
(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)))))
(should (equal (seq-subseq err 0 2)
(if (eq system-type 'windows-nt)
'(permission-denied "Testing file lock")
'(file-error "Testing file lock")))))))
(ert-deftest filelock-tests-unlock-spoiled ()
"Check that `unlock-buffer' fails if the lockfile is \"spoiled\"."
(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))
(set-buffer-modified-p t))
(should-not (file-locked-p buffer-file-truename))
(filelock-tests--spoil-lock-file buffer-file-truename)
;; Errors from `unlock-buffer' should call
;; `userlock--handle-unlock-error' (bug#46397).
(cl-letf (((symbol-function 'userlock--handle-unlock-error)
(lambda (err) (signal (car err) (cdr err)))))
(should (equal
(if (eq system-type 'windows-nt)
'(permission-denied "Unlocking file")
'(file-error "Unlocking file"))
(seq-subseq (should-error (unlock-buffer)) 0 2))))))
(ert-deftest filelock-tests-kill-buffer-spoiled ()
"Check that `kill-buffer' fails if a lockfile is \"spoiled\"."
(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))
(set-buffer-modified-p t))
(should-not (file-locked-p buffer-file-truename))
(filelock-tests--spoil-lock-file buffer-file-truename)
;; Kill the current buffer. Because the buffer is modified Emacs
;; will attempt to unlock it. Temporarily bind `yes-or-no-p' to a
;; function that fakes a "yes" answer for the "Buffer modified;
;; kill anyway?" prompt.
;;
;; File errors from unlocking files should call
;; `userlock--handle-unlock-error' (bug#46397).
(cl-letf (((symbol-function 'yes-or-no-p) #'always)
((symbol-function 'userlock--handle-unlock-error)
(lambda (err) (signal (car err) (cdr err)))))
(should (equal
(if (eq system-type 'windows-nt)
'(permission-denied "Unlocking file")
'(file-error "Unlocking file"))
(seq-subseq (should-error (kill-buffer)) 0 2))))))
(ert-deftest filelock-tests-detect-external-change ()
"Check that an external file modification is reported."
(skip-when (eq system-type 'ms-dos)) ; no filelock support
(skip-unless (executable-find "touch"))
(skip-unless (executable-find "echo"))
(dolist (cl '(t nil))
(filelock-tests--fixture
(let ((create-lockfiles cl))
(write-region "foo" nil (buffer-file-name))
(revert-buffer nil 'noconfirm)
(should-not (file-locked-p (buffer-file-name)))
;; Just changing the file modification on disk doesn't hurt,
;; because file contents in buffer and on disk look equal.
(shell-command (format "touch %s"
(shell-quote-argument (buffer-file-name))))
(insert "bar")
(when cl (filelock-tests--should-be-locked))
;; Bug#53207: with `create-lockfiles' nil, saving the buffer
;; results in a prompt.
(cl-letf (((symbol-function 'yes-or-no-p)
(lambda (_) (ert-fail "Test failed unexpectedly"))))
(save-buffer))
(should-not (file-locked-p (buffer-file-name)))
;; Changing the file contents on disk hurts when buffer is
;; modified. There shall be a query, which we answer.
;; *Messages* buffer is checked for prompt.
(shell-command (format "echo bar >>%s"
(shell-quote-argument (buffer-file-name))))
(cl-letf (((symbol-function 'read-char-choice)
(lambda (prompt &rest _) (message "%s" prompt) ?y)))
(ert-with-message-capture captured-messages
;; `ask-user-about-supersession-threat' does not work in
;; batch mode, let's simulate interactiveness.
(let (noninteractive)
(insert "baz"))
(should (string-match-p
(format
"^%s changed on disk; really edit the buffer\\?"
(file-name-nondirectory (buffer-file-name)))
captured-messages))))
(when cl (filelock-tests--should-be-locked))))))
(provide 'filelock-tests)
;;; filelock-tests.el ends here
|
