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
|
;;; filelock-tests.el --- test file locking -*- lexical-binding: t; -*-
;; Copyright (C) 2021 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-macs)
(require 'ert)
(require 'seq)
(defun filelock-tests--fixture (test-function)
"Call TEST-FUNCTION 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
TEST-FUNCTION. Finally, delete the buffer and the test
directory."
(let* ((temp-dir (make-temp-file "filelock-tests" t))
(name (concat (file-name-as-directory temp-dir)
"userfile"))
(create-lockfiles t))
(unwind-protect
(with-temp-buffer
(setq buffer-file-name name
buffer-file-truename name)
(unwind-protect
(save-current-buffer
(funcall test-function))
;; 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)))
(delete-directory temp-dir t 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
(lambda ()
(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-unless (not (eq system-type 'ms-dos))) ; no filelock support
(filelock-tests--fixture
(lambda ()
(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-unless (not (eq system-type 'ms-dos))) ; no filelock support
(filelock-tests--fixture
(lambda ()
(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)
'(file-error "Testing file lock")))))))
(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
(filelock-tests--fixture
(lambda ()
;; 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).
(let (errors)
(cl-letf (((symbol-function 'userlock--handle-unlock-error)
(lambda (err) (push err errors))))
(unlock-buffer))
(should (consp errors))
(should (equal '(file-error "Unlocking file")
(seq-subseq (car errors) 0 2)))
(should (equal (length errors) 1))))))
(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
(filelock-tests--fixture
(lambda ()
;; 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).
(let (errors)
(cl-letf (((symbol-function 'yes-or-no-p)
(lambda (&rest _) t))
((symbol-function 'userlock--handle-unlock-error)
(lambda (err) (push err errors))))
(kill-buffer))
(should (consp errors))
(should (equal '(file-error "Unlocking file")
(seq-subseq (car errors) 0 2)))
(should (equal (length errors) 1))))))
(provide 'filelock-tests)
;;; filelock-tests.el ends here
|
