commit 0057caa53c4b0c624f6ede9ffea6a4262ccffd69 (HEAD, refs/remotes/origin/master) Author: Michael Albinus Date: Mon Mar 29 10:15:45 2021 +0200 * test/infra/gitlab-ci.yml (test-filenotify-gio): Use *.log for make_params. diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index bb79dc0161..25231f5504 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -237,7 +237,7 @@ test-filenotify-gio: extends: [.job-template, .test-template, .filenotify-gio-template] variables: target: emacs-filenotify-gio - make_params: "-k -C test autorevert-tests filenotify-tests" + make_params: "-k -C test autorevert-tests.log filenotify-tests.log" test-gnustep: # This tests the GNUstep build process commit ee3a4e3d1be656cd0df71ed197dc5f102556f0e0 Author: Lars Ingebrigtsen Date: Sun Mar 28 19:22:15 2021 +0200 Fix a dbus.el byte compilation warning * lisp/net/dbus.el (dbus-register-monitor): Silence a byte-compilation warning on systems without dbus. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 1e7f836d82..4116d293e1 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -2029,8 +2029,9 @@ either a method name, a signal name, or an error name." ",") rule (or rule "")) - (unless (ignore-errors (dbus-get-unique-name bus-private)) - (dbus-init-bus bus 'private)) + (when (fboundp 'dbus-get-unique-name) + (unless (ignore-errors (dbus-get-unique-name bus-private)) + (dbus-init-bus bus 'private))) (dbus-call-method bus-private dbus-service-dbus dbus-path-dbus dbus-interface-monitoring "BecomeMonitor" `(:array :string ,rule) :uint32 0) commit 216c65b135c2b0be7e048cdc6683873b03b99b9a Author: Lars Ingebrigtsen Date: Sun Mar 28 19:13:00 2021 +0200 Use a 64KB page size for pdump * src/pdumper.c (dump_get_page_size): Use a 64KB page size on all architectures, as this many vary between systems (bug#47125). diff --git a/src/pdumper.c b/src/pdumper.c index 337742fda4..fdd9b3bacb 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -162,11 +162,7 @@ ptrdiff_t_to_dump_off (ptrdiff_t value) static int dump_get_page_size (void) { -#if defined (WINDOWSNT) || defined (CYGWIN) - return 64 * 1024; /* Worst-case allocation granularity. */ -#else - return getpagesize (); -#endif + return 64 * 1024; } #define dump_offsetof(type, member) \ commit 81b56434a536f2f8849957e23f2bc3f83e16751f Author: Michael Albinus Date: Sun Mar 28 19:16:12 2021 +0200 * admin/notes/emba: Explain job types and artifacts. diff --git a/admin/notes/emba b/admin/notes/emba index adebcefcf3..05d8eb8353 100644 --- a/admin/notes/emba +++ b/admin/notes/emba @@ -36,6 +36,21 @@ of the Emacs git repository to perform a bootstrap and test of Emacs. This could happen for several jobs with changed configuration, compile and test parameters. +There are different types of jobs: 'prep-image-base' is responsible to +prepare the environment for the following jobs. 'build-image-*' jobs +are responsible to compile Emacs in different configuration. The +corresponding 'test-*' jobs run the ert tests. + +A special job is 'test-all-inotify', which runs 'make check-expensive'. +While most of the jobs run as soon as a respective file has been +committed into the Emacs git repository, this test job runs scheduled, +every 6 hours. + +The log files for every test job are kept on the server for a week. +They can be downloaded from the server, visiting the URL +, and selecting the job +in question. + * Emba configuration The emba configuration files are hosted on commit 01cf0eb75786834b7a0ee5be34be53f6e8e14c11 Author: Lars Ingebrigtsen Date: Sun Mar 28 17:06:01 2021 +0200 Revert "Clarify dired-do-shell-command doc string" This reverts commit cf607c262e15c873961fdfcced254e6f8e82f8d7. The doc string already explains this. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index eea2188142..d5f4910876 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -826,8 +826,6 @@ If no files are marked or a numeric prefix arg is given, the next ARG files are used. Just \\[universal-argument] means the current file. The prompt mentions the file(s) or the marker, as appropriate. -When executing, FILE-LIST is appended to the COMMAND string. - If there is a `*' in COMMAND, surrounded by whitespace, this runs COMMAND just once with the entire file list substituted there. commit cf607c262e15c873961fdfcced254e6f8e82f8d7 Author: Lars Ingebrigtsen Date: Sun Mar 28 16:01:53 2021 +0200 Clarify dired-do-shell-command doc string * lisp/dired-aux.el (dired-do-shell-command): Mention what happens to FILE-LIST (bug#47432). diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index d5f4910876..eea2188142 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -826,6 +826,8 @@ If no files are marked or a numeric prefix arg is given, the next ARG files are used. Just \\[universal-argument] means the current file. The prompt mentions the file(s) or the marker, as appropriate. +When executing, FILE-LIST is appended to the COMMAND string. + If there is a `*' in COMMAND, surrounded by whitespace, this runs COMMAND just once with the entire file list substituted there. commit 8b754ca318cb88d9e5f437ccd919a722d345f13f Author: pillule Date: Sun Mar 28 15:18:26 2021 +0200 compilation-goto-locus does not handle right display-buffer * lisp/progmodes/compile.el (compilation-goto-locus): Pop to the source buffer if the match buffer is the selected window (bug#47414). Copyright-paperwork-exempt: yes diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index d23c77ef86..7a02c3a896 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -2844,8 +2844,9 @@ and overlay is highlighted between MK and END-MK." (when (and (not pre-existing) w) (compilation-set-window-height w)) - (if from-compilation-buffer - ;; If the compilation buffer window was selected, + (if (or from-compilation-buffer + (eq w (selected-window))) + ;; If the compilation buffer window is selected, ;; keep the compilation buffer in this window; ;; display the source in another window. (let ((pop-up-windows t)) commit 661f52f6d0d6576e8bddb8fcc6efec1bd1fd3d74 Author: Lars Ingebrigtsen Date: Sun Mar 28 14:58:43 2021 +0200 Clarify the doc string of plist-memeber and plist-put * src/fns.c (Fplist_member): (Fplist_put): Clarify what comparison function is used for PROP (bug#47426) and don't claim that PROP has to be a symbol. diff --git a/src/fns.c b/src/fns.c index 2cd59c83d9..1758148ff2 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2369,7 +2369,10 @@ This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */) DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0, doc: /* Change value in PLIST of PROP to VAL. PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object. +\(PROP1 VALUE1 PROP2 VALUE2 ...). + +The comparison with PROP is done using `eq'. + If PROP is already a property on the list, its value is set to VAL, otherwise the new PROP VAL pair is added. The new plist is returned; use `(setq x (plist-put x prop val))' to be sure to use the new value. @@ -3211,7 +3214,10 @@ suppressed. */) DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0, doc: /* Return non-nil if PLIST has the property PROP. PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol. +\(PROP1 VALUE1 PROP2 VALUE2 ...). + +The comparison with PROP is done using `eq'. + Unlike `plist-get', this allows you to distinguish between a missing property and a property with the value nil. The value is actually the tail of PLIST whose car is PROP. */) commit aceaa0a334a9e1a90ba3715e144d147a77aedc95 Author: Eli Zaretskii Date: Sun Mar 28 15:29:41 2021 +0300 Avoid errors in pulse.el for some face customizations * lisp/cedet/pulse.el (pulse-momentary-highlight-overlay): Make sure 'face-background' always returns a color name. Suggested by Ingo Lohmar in bug#47437. diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el index d77d635f97..1e4506713a 100644 --- a/lisp/cedet/pulse.el +++ b/lisp/cedet/pulse.el @@ -153,7 +153,8 @@ Optional argument FACE specifies the face to do the highlighting." ;; with a reference face needed for the color. (pulse-reset-face face) (let* ((start (color-name-to-rgb - (face-background 'pulse-highlight-start-face))) + (face-background 'pulse-highlight-start-face + nil 'default))) (stop (color-name-to-rgb (face-background 'default))) (colors (mapcar (apply-partially 'apply 'color-rgb-to-hex) (color-gradient start stop pulse-iterations)))) commit 96a45935989acc400025bde50258aeb3b499716e Author: Michael Albinus Date: Sun Mar 28 10:08:00 2021 +0200 Make artifacts working on emba (hopefully) * test/infra/gitlab-ci.yml (.job-template): Use proper docker name. (.test-template): Adapt artifacts path. diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index d061a69c66..bb79dc0161 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -104,11 +104,11 @@ default: - 'export PWD=$(pwd)' - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' after_script: - - docker ps -a - - printenv - - test -n "${make_params}" && ( docker export ${test_name} | tar -tvf - ) || true - # - test -n "${make_params}" && ( mkdir test-${test_name}; docker cp ${test_name}:test test-${test_name} ) || true - - docker rm ${test_name} + # - docker ps -a + # - printenv + # - test -n "$(docker ps -aq -f name=${test_name})" && ( docker export ${test_name} | tar -tvf - ) + - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} + - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} .build-template: rules: @@ -146,7 +146,7 @@ default: expire_in: 1 week when: always paths: - - "test-${test_name}/**/*.log" + - "${test_name}/**/*.log" .gnustep-template: rules: commit 669e30c0a35c8af815b1175bad6025bb12e7f809 Author: Michael Albinus Date: Sat Mar 27 21:27:35 2021 +0100 ; Adapt recent change in test/infra/gitlab-ci.yml diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 77153f63ac..d061a69c66 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -106,7 +106,8 @@ default: after_script: - docker ps -a - printenv - - ( test ${CI_JOB_STAGE} == fast ) && ( mkdir test-${test_name}; docker cp ${test_name}:test test-${test_name} ) || true + - test -n "${make_params}" && ( docker export ${test_name} | tar -tvf - ) || true + # - test -n "${make_params}" && ( mkdir test-${test_name}; docker cp ${test_name}:test test-${test_name} ) || true - docker rm ${test_name} .build-template: commit 8bf186b2297dc0aeba76e8e743dec7efa6a568e4 Author: Basil L. Contovounesios Date: Sat Mar 27 19:25:38 2021 +0000 Demote read-extended-command-predicate errors For discussion, see the following thread: https://lists.gnu.org/r/emacs-devel/2021-03/msg00682.html * lisp/simple.el (read-extended-command): Demote errors when calling read-extended-command-predicate so M-x completion doesn't break. diff --git a/lisp/simple.el b/lisp/simple.el index 959bd83117..c48e644345 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2005,9 +2005,14 @@ This function uses the `read-extended-command-predicate' user option." (complete-with-action action obarray string pred))) (lambda (sym) (and (commandp sym) - (or (null read-extended-command-predicate) - (and (functionp read-extended-command-predicate) - (funcall read-extended-command-predicate sym buffer))))) + (cond ((null read-extended-command-predicate)) + ((functionp read-extended-command-predicate) + ;; Don't let bugs break M-x completion; interpret + ;; them as the absence of a predicate. + (condition-case-unless-debug err + (funcall read-extended-command-predicate sym buffer) + (error (message "read-extended-command-predicate: %s: %s" + sym (error-message-string err)))))))) t nil 'extended-command-history)))) (defun command-completion-using-modes-p (symbol buffer) commit 56081645cc91c6f4259fa7d1a938fc781fbcb0da Author: Michael Albinus Date: Sat Mar 27 20:19:27 2021 +0100 ; Adapt recent change in test/infra/gitlab-ci.yml diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index fdca12b27a..77153f63ac 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -106,7 +106,7 @@ default: after_script: - docker ps -a - printenv - - [ ${CI_JOB_STAGE} == fast ] && ( mkdir test-${test_name}; docker cp ${test_name}:test test-${test_name} ) || true + - ( test ${CI_JOB_STAGE} == fast ) && ( mkdir test-${test_name}; docker cp ${test_name}:test test-${test_name} ) || true - docker rm ${test_name} .build-template: commit c52cf64adb0e47c9179f00e00a8980e86b864abd Author: Michael Albinus Date: Sat Mar 27 20:14:22 2021 +0100 ; Adapt recent change in test/infra/gitlab-ci.yml diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 91315ad21d..fdca12b27a 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -104,7 +104,10 @@ default: - 'export PWD=$(pwd)' - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' after_script: - - 'docker rm ${test_name}' + - docker ps -a + - printenv + - [ ${CI_JOB_STAGE} == fast ] && ( mkdir test-${test_name}; docker cp ${test_name}:test test-${test_name} ) || true + - docker rm ${test_name} .build-template: rules: @@ -136,10 +139,6 @@ default: - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} .test-template: - script: - - mkdir test-${test_name} - - docker ps -a - - docker cp ${test_name}:test test-${test_name} artifacts: name: ${test_name} public: true commit 547960488dbcba72864cf86ccf9a6efb7d4cb11b Author: Stefan Monnier Date: Sat Mar 27 14:31:40 2021 -0400 * lisp/wdired.el (wdired--self-insert): Fix thinko diff --git a/lisp/wdired.el b/lisp/wdired.el index 567ebb122a..ff42d784e5 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -288,10 +288,9 @@ or \\[wdired-abort-changes] to abort changes"))) (if (wdired--line-preprocessed-p) (call-interactively 'self-insert-command) (wdired--before-change-fn (point) (point)) - (let ((map (get-text-property (point) 'keymap))) - (when map - (let ((cmd (lookup-key map (this-command-keys)))) - (call-interactively (or cmd 'self-insert-command))))))) + (let* ((map (get-text-property (point) 'keymap))) + (call-interactively (or (if map (lookup-key map (this-command-keys))) + #'self-insert-command))))) (defun wdired--before-change-fn (beg end) (save-excursion commit 526220c53dd22bcfbd1daad321143c3d13e92a7b Author: Michael Albinus Date: Sat Mar 27 17:47:43 2021 +0100 ; Adapt recent change in test/infra/gitlab-ci.yml diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 16f7f3ca15..91315ad21d 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -102,11 +102,9 @@ default: - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it - 'export PWD=$(pwd)' - - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' + - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' after_script: - - 'docker ps -a' - - 'docker cp $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):test test-${test_name}' - - 'docker rm $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}")' + - 'docker rm ${test_name}' .build-template: rules: @@ -138,6 +136,10 @@ default: - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} .test-template: + script: + - mkdir test-${test_name} + - docker ps -a + - docker cp ${test_name}:test test-${test_name} artifacts: name: ${test_name} public: true commit 6d943f682cc97a164cd946cabe4bf0156aff7073 Author: Michael Albinus Date: Sat Mar 27 16:49:09 2021 +0100 ; Adapt recent change in test/infra/gitlab-ci.yml diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index fe34e2b213..16f7f3ca15 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -61,6 +61,8 @@ default: - docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} ${CI_REGISTRY} .job-template: + variables: + test_name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA} rules: - changes: - "**/Makefile.in" @@ -100,7 +102,11 @@ default: - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it - 'export PWD=$(pwd)' - - 'docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' + - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' + after_script: + - 'docker ps -a' + - 'docker cp $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):test test-${test_name}' + - 'docker rm $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}")' .build-template: rules: @@ -132,15 +138,13 @@ default: - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} .test-template: - after_script: - - docker cp $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):test test artifacts: - name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA} + name: ${test_name} public: true expire_in: 1 week when: always paths: - - "**/*.log" + - "test-${test_name}/**/*.log" .gnustep-template: rules: commit 6838cc50f94f7b1f1d985961761cc5db232f6c02 Author: Stefan Monnier Date: Sat Mar 27 10:54:10 2021 -0400 * lisp/wdired.el: Fix minor regressions and simplify a bit Use `wdired--current-column` more consistently to avoid mayhem when it doesn't return the same result as `current-column`. (wdired-get-filename): Fix the unprocessed case. (wdired-finish-edit): Don't force processing all the lines. (wdired--col-perm): Remove, redundant with `wdired--perm-beg`. (wdired-change-to-wdired-mode): Don't error in empty directory. (wdired--set-permission-bounds): Set `wdired--perm-beg` when we can't find permissions. Move `wdired--perm-beg` 1 char further (like `wdired--col-perm`). Use `wdired--current-column`. (wdired--point-at-perms-p): Fix when `wdired--perm-beg` is nil. (wdired--self-insert): Lookup the keymap to know command to call. (wdired--before-change-fn): Just use `point` instead of `beg`. Use `with-silent-modifications` here rather than in each of the `wdired--preprocess-*` functions. (wdired--preprocess-files): Presume we're at BOL and within `with-silent-modifications`. Fix application of `read-only`. (wdired-abort-changes): Don't use `with-silent-modifications` since we're really modifying the buffer. (wdired--preprocess-symlinks): Presume we're at BOL and within `with-silent-modifications`. (wdired--preprocess-perms): Presume we're at BOL and within `with-silent-modifications`. (wdired-set-bit): Add `char` argument. Use `wdired--current-column`. Copy previous text properties rather than duplicating the code of `wdired--preprocess-perms`. (wdired-toggle-bit): Delegate to `wdired-set-bit`. diff --git a/lisp/wdired.el b/lisp/wdired.el index 61272d947f..567ebb122a 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -189,7 +189,6 @@ nonexistent directory will fail." "Hooks run when changing to WDired mode.") ;; Local variables (put here to avoid compilation gripes) -(defvar wdired--col-perm) ;; Column where the permission bits start (defvar wdired--perm-beg) ;; Column where the permission bits start (defvar wdired--perm-end) ;; Column where the permission bits stop (defvar wdired--old-content) @@ -233,8 +232,6 @@ See `wdired-mode'." (interactive) (unless (derived-mode-p 'dired-mode) (error "Not a Dired buffer")) - (when (directory-empty-p (expand-file-name default-directory)) - (error "No files to be renamed")) (setq-local wdired--old-content (buffer-substring (point-min) (point-max))) (setq-local wdired--old-marks @@ -264,49 +261,60 @@ or \\[wdired-abort-changes] to abort changes"))) (defun wdired--set-permission-bounds () (save-excursion (goto-char (point-min)) - (re-search-forward dired-re-perms nil t 1) - (goto-char (match-beginning 0)) - (setq-local wdired--perm-beg (current-column)) - (goto-char (match-end 0)) - (setq-local wdired--perm-end (current-column)))) + (if (not (re-search-forward dired-re-perms nil t 1)) + (progn + (setq-local wdired--perm-beg nil) + (setq-local wdired--perm-end nil)) + (goto-char (match-beginning 0)) + ;; Add 1 since the first char matched by `dired-re-perms' is the + ;; one describing the nature of the entry (dir/symlink/...) rather + ;; than its permissions. + (setq-local wdired--perm-beg (1+ (wdired--current-column))) + (goto-char (match-end 0)) + (setq-local wdired--perm-end (wdired--current-column))))) (defun wdired--current-column () (- (point) (line-beginning-position))) (defun wdired--point-at-perms-p () - (<= wdired--perm-beg (wdired--current-column) wdired--perm-end)) + (and wdired--perm-beg + (<= wdired--perm-beg (wdired--current-column) wdired--perm-end))) (defun wdired--line-preprocessed-p () (get-text-property (line-beginning-position) 'front-sticky)) (defun wdired--self-insert () (interactive) - (if (wdired--point-at-perms-p) - (unless (wdired--line-preprocessed-p) - (wdired--before-change-fn (line-beginning-position) (line-end-position)) - (wdired-toggle-bit)) - (call-interactively 'self-insert-command))) + (if (wdired--line-preprocessed-p) + (call-interactively 'self-insert-command) + (wdired--before-change-fn (point) (point)) + (let ((map (get-text-property (point) 'keymap))) + (when map + (let ((cmd (lookup-key map (this-command-keys)))) + (call-interactively (or cmd 'self-insert-command))))))) (defun wdired--before-change-fn (beg end) (save-excursion - ;; make sure to process entire lines - (goto-char beg) - (setq beg (line-beginning-position)) + ;; Make sure to process entire lines. (goto-char end) (setq end (line-end-position)) + (goto-char beg) + (forward-line 0) - (while (< beg end) + (while (< (point) end) (unless (wdired--line-preprocessed-p) - (put-text-property beg (1+ beg) 'front-sticky t) - (wdired--preprocess-files) - (when wdired-allow-to-change-permissions - (wdired--preprocess-perms)) - (when (fboundp 'make-symbolic-link) - (wdired--preprocess-symlinks))) - (forward-line) - (setq beg (point))) - ;; is this good enough? assumes no extra white lines from dired - (put-text-property (1- (point-max)) (point-max) 'read-only t))) + (with-silent-modifications + (put-text-property (point) (1+ (point)) 'front-sticky t) + (wdired--preprocess-files) + (when wdired-allow-to-change-permissions + (wdired--preprocess-perms)) + (when (fboundp 'make-symbolic-link) + (wdired--preprocess-symlinks)))) + (forward-line)) + (when (eobp) + (with-silent-modifications + ;; Is this good enough? Assumes no extra white lines from dired. + (put-text-property (1- (point-max)) (point-max) 'read-only t))))) (defun wdired-isearch-filter-read-only (beg end) "Skip matches that have a read-only property." @@ -317,28 +325,26 @@ or \\[wdired-abort-changes] to abort changes"))) ;; properties so filenames (old and new) can be easily found. (defun wdired--preprocess-files () (save-excursion - (with-silent-modifications - (beginning-of-line) - (let ((used-F (dired-check-switches dired-actual-switches "F" "classify")) - filename) - (setq filename (dired-get-filename nil t)) - (when (and filename - (not (member (file-name-nondirectory filename) '("." "..")))) - (dired-move-to-filename) - ;; The rear-nonsticky property below shall ensure that text preceding - ;; the filename can't be modified. - (add-text-properties - (1- (point)) (point) `(old-name ,filename rear-nonsticky (read-only))) - (put-text-property (- (point) 1) (point) 'read-only t) - (dired-move-to-end-of-filename t) - (put-text-property (point) (1+ (point)) 'end-name t)) - (when (and used-F (looking-at "[*/@|=>]$")) (forward-char)) - (when (save-excursion - (and (re-search-backward - dired-permission-flags-regexp nil t) - (looking-at "l") - (search-forward " -> " (line-end-position) t))) - (goto-char (line-end-position))))))) + (let ((used-F (dired-check-switches dired-actual-switches "F" "classify")) + (beg (point)) + (filename (dired-get-filename nil t))) + (when (and filename + (not (member (file-name-nondirectory filename) '("." "..")))) + (dired-move-to-filename) + ;; The rear-nonsticky property below shall ensure that text preceding + ;; the filename can't be modified. + (add-text-properties + (1- (point)) (point) `(old-name ,filename rear-nonsticky (read-only))) + (put-text-property beg (point) 'read-only t) + (dired-move-to-end-of-filename t) + (put-text-property (point) (1+ (point)) 'end-name t)) + (when (and used-F (looking-at "[*/@|=>]$")) (forward-char)) + (when (save-excursion + (and (re-search-backward + dired-permission-flags-regexp nil t) + (looking-at "l") + (search-forward " -> " (line-end-position) t))) + (goto-char (line-end-position)))))) ;; This code is a copy of some dired-get-filename lines. (defsubst wdired-normalize-filename (file unquotep) @@ -365,6 +371,7 @@ non-nil means return old filename." ;; FIXME: Use dired-get-filename's new properties. (let ((used-F (dired-check-switches dired-actual-switches "F" "classify")) beg end file) + (wdired--before-change-fn (point) (point)) (save-excursion (setq end (line-end-position)) (beginning-of-line) @@ -425,8 +432,8 @@ non-nil means return old filename." (defun wdired-abort-changes () "Abort changes and return to dired mode." (interactive) - (remove-hook 'before-change-functions 'wdired--before-change-fn t) - (with-silent-modifications + (remove-hook 'before-change-functions #'wdired--before-change-fn t) + (let ((inhibit-read-only t)) (erase-buffer) (insert wdired--old-content) (goto-char wdired--old-point)) @@ -451,13 +458,14 @@ non-nil means return old filename." (setq errors (cdr tmp-value)) (setq changes (car tmp-value))) (when (and wdired-allow-to-change-permissions - (boundp 'wdired--col-perm)) ; could have been changed + wdired--perm-beg) ; could have been changed (setq tmp-value (wdired-do-perm-changes)) (setq errors (+ errors (cdr tmp-value))) (setq changes (or changes (car tmp-value)))) (goto-char (point-max)) (while (not (bobp)) - (setq file-old (wdired-get-filename nil t)) + (setq file-old (and (wdired--line-preprocessed-p) + (wdired-get-filename nil t))) (when file-old (setq file-new (wdired-get-filename)) (if (equal file-new file-old) @@ -744,17 +752,15 @@ says how many lines to move; default is one line." ;; Put the needed properties to allow the user to change links' targets (defun wdired--preprocess-symlinks () (save-excursion - (with-silent-modifications - (beginning-of-line) - (when (looking-at dired-re-sym) - (re-search-forward " -> \\(.*\\)$") - (put-text-property (1- (match-beginning 1)) - (match-beginning 1) 'old-link - (match-string-no-properties 1)) - (put-text-property (match-end 1) (1+ (match-end 1)) 'end-link t) - (unless wdired-allow-to-redirect-links - (put-text-property (match-beginning 0) - (match-end 1) 'read-only t)))))) + (when (looking-at dired-re-sym) + (re-search-forward " -> \\(.*\\)$") + (put-text-property (1- (match-beginning 1)) + (match-beginning 1) 'old-link + (match-string-no-properties 1)) + (put-text-property (match-end 1) (1+ (match-end 1)) 'end-link t) + (unless wdired-allow-to-redirect-links + (put-text-property (match-beginning 0) + (match-end 1) 'read-only t))))) (defun wdired-get-previous-link (&optional old move) "Return the next symlink target. @@ -861,31 +867,26 @@ Like original function but it skips read-only words." ;; original name and permissions as a property (defun wdired--preprocess-perms () (save-excursion - (with-silent-modifications - (setq-local wdired--col-perm nil) - (beginning-of-line) - (when (and (not (looking-at dired-re-sym)) - (wdired-get-filename) - (re-search-forward dired-re-perms - (line-end-position) 'eol)) - (let ((begin (match-beginning 0)) - (end (match-end 0))) - (unless wdired--col-perm - (setq wdired--col-perm (- (current-column) 9))) - (if (eq wdired-allow-to-change-permissions 'advanced) - (progn - (put-text-property begin end 'read-only nil) - ;; make first permission bit writable - (put-text-property - (1- begin) begin 'rear-nonsticky '(read-only))) - ;; avoid that keymap applies to text following permissions - (add-text-properties - (1+ begin) end - `(keymap ,wdired-perm-mode-map rear-nonsticky (keymap)))) - (put-text-property end (1+ end) 'end-perm t) - (put-text-property - begin (1+ begin) - 'old-perm (match-string-no-properties 0))))))) + (when (and (not (looking-at dired-re-sym)) + (wdired-get-filename) + (re-search-forward dired-re-perms + (line-end-position) 'eol)) + (let ((begin (match-beginning 0)) + (end (match-end 0))) + (if (eq wdired-allow-to-change-permissions 'advanced) + (progn + (put-text-property begin end 'read-only nil) + ;; make first permission bit writable + (put-text-property + (1- begin) begin 'rear-nonsticky '(read-only))) + ;; avoid that keymap applies to text following permissions + (add-text-properties + (1+ begin) end + `(keymap ,wdired-perm-mode-map rear-nonsticky (keymap)))) + (put-text-property end (1+ end) 'end-perm t) + (put-text-property + begin (1+ begin) + 'old-perm (match-string-no-properties 0)))))) (defun wdired-perm-allowed-in-pos (char pos) (cond @@ -897,39 +898,30 @@ Like original function but it skips read-only words." ((memq char '(?t ?T)) (= pos 8)) ((= char ?l) (= pos 5)))) -(defun wdired-set-bit () +(defun wdired-set-bit (&optional char) "Set a permission bit character." - (interactive) - (if (wdired-perm-allowed-in-pos last-command-event - (- (current-column) wdired--col-perm)) - (let ((new-bit (char-to-string last-command-event)) + (interactive (list last-command-event)) + (unless char (setq char last-command-event)) + (if (wdired-perm-allowed-in-pos char + (- (wdired--current-column) wdired--perm-beg)) + (let ((new-bit (char-to-string char)) (inhibit-read-only t) - (pos-prop (- (point) (- (current-column) wdired--col-perm)))) - (put-text-property 0 1 'keymap wdired-perm-mode-map new-bit) - (put-text-property 0 1 'read-only t new-bit) + (pos-prop (+ (line-beginning-position) wdired--perm-beg))) + (set-text-properties 0 1 (text-properties-at (point)) new-bit) (insert new-bit) (delete-char 1) - (put-text-property (1- pos-prop) pos-prop 'perm-changed t) - (put-text-property (1- (point)) (point) 'rear-nonsticky '(keymap))) + (put-text-property (1- pos-prop) pos-prop 'perm-changed t)) (forward-char 1))) (defun wdired-toggle-bit () "Toggle the permission bit at point." (interactive) - (let ((inhibit-read-only t) - (new-bit "-") - (pos-prop (- (point) (- (current-column) wdired--col-perm)))) - (if (eq (char-after (point)) ?-) - (setq new-bit - (if (= (% (- (current-column) wdired--col-perm) 3) 0) "r" - (if (= (% (- (current-column) wdired--col-perm) 3) 1) "w" - "x")))) - (put-text-property 0 1 'keymap wdired-perm-mode-map new-bit) - (put-text-property 0 1 'read-only t new-bit) - (insert new-bit) - (delete-char 1) - (put-text-property (1- pos-prop) pos-prop 'perm-changed t) - (put-text-property (1- (point)) (point) 'rear-nonsticky '(keymap)))) + (wdired-set-bit + (cond + ((not (eq (char-after (point)) ?-)) ?-) + ((= (% (- (wdired--current-column) wdired--perm-beg) 3) 0) ?r) + ((= (% (- (wdired--current-column) wdired--perm-beg) 3) 1) ?w) + (t ?x)))) (defun wdired-mouse-toggle-bit (event) "Toggle the permission bit that was left clicked." commit e26d0e611aaf477a88119c506f942036c338688f Author: Michael Albinus Date: Sat Mar 27 14:57:32 2021 +0100 ; Adapt recent change in test/infra/gitlab-ci.yml diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index c957bf9b4d..fe34e2b213 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -132,8 +132,10 @@ default: - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} .test-template: + after_script: + - docker cp $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):test test artifacts: - name: ${CI_JOB_NAME}-${CI_COMMIT_SHA} + name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA} public: true expire_in: 1 week when: always @@ -234,7 +236,7 @@ test-filenotify-gio: test-gnustep: # This tests the GNUstep build process stage: platforms - extends: [.job-template, .test-template, .gnustep-template] + extends: [.job-template, .gnustep-template] variables: target: emacs-gnustep make_params: install commit 4dbc44550da640529c7ded7378caf0db439b0bbd Author: Arthur Miller Date: Sat Mar 27 08:29:44 2021 +0100 * lisp/wdired.el: Apply text properties lazily Entering wdired was taking time proportional to the size of the directory, making it inconvenient to quickly enter wdired just to rename one or two files in a large directory. (wdired-mode-map): Rebind `self-insert-command`. (wdired--perm-beg, wdired--perm-end): New vars. (wdired--col-perm, wdired--old-content, wdired--old-point) (wdired--old-marks): Rename vars, using "--" rather than "-". All users updated. (wdired--before-change-fn): New function. (wdired-change-to-wdired-mode): Use it `before-change-functions` instead of eagerly putting the various text properties here. (wdired--set-permission-bounds, wdired--current-column) (wdired--point-at-perms-p, wdired--line-preprocessed-p): New auxiliary functions. (wdired--self-insert): New command. (wdired--preprocess-files, wdired--preprocess-symlinks) (wdired--preprocess-perms): Add "--" to the name. Make it operate only on the current line. Use `with-silent-modifications`. (wdired-abort-changes): Use `with-silent-modifications`. diff --git a/lisp/wdired.el b/lisp/wdired.el index 43026d4bb7..61272d947f 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -172,6 +172,7 @@ nonexistent directory will fail." (define-key map [remap upcase-word] #'wdired-upcase-word) (define-key map [remap capitalize-word] #'wdired-capitalize-word) (define-key map [remap downcase-word] #'wdired-downcase-word) + (define-key map [remap self-insert-command] #'wdired--self-insert) map) "Keymap used in `wdired-mode'.") @@ -188,10 +189,12 @@ nonexistent directory will fail." "Hooks run when changing to WDired mode.") ;; Local variables (put here to avoid compilation gripes) -(defvar wdired-col-perm) ;; Column where the permission bits start -(defvar wdired-old-content) -(defvar wdired-old-point) -(defvar wdired-old-marks) +(defvar wdired--col-perm) ;; Column where the permission bits start +(defvar wdired--perm-beg) ;; Column where the permission bits start +(defvar wdired--perm-end) ;; Column where the permission bits stop +(defvar wdired--old-content) +(defvar wdired--old-point) +(defvar wdired--old-marks) (defun wdired-mode () "Writable Dired (WDired) mode. @@ -230,11 +233,14 @@ See `wdired-mode'." (interactive) (unless (derived-mode-p 'dired-mode) (error "Not a Dired buffer")) - (setq-local wdired-old-content + (when (directory-empty-p (expand-file-name default-directory)) + (error "No files to be renamed")) + (setq-local wdired--old-content (buffer-substring (point-min) (point-max))) - (setq-local wdired-old-marks + (setq-local wdired--old-marks (dired-remember-marks (point-min) (point-max))) - (setq-local wdired-old-point (point)) + (setq-local wdired--old-point (point)) + (wdired--set-permission-bounds) (setq-local query-replace-skip-read-only t) (add-function :after-while (local 'isearch-filter-predicate) #'wdired-isearch-filter-read-only) @@ -243,20 +249,11 @@ See `wdired-mode'." (setq buffer-read-only nil) (dired-unadvertise default-directory) (add-hook 'kill-buffer-hook #'wdired-check-kill-buffer nil t) + (add-hook 'before-change-functions #'wdired--before-change-fn nil t) (add-hook 'after-change-functions #'wdired--restore-properties nil t) (setq major-mode 'wdired-mode) (setq mode-name "Editable Dired") (add-function :override (local 'revert-buffer-function) #'wdired-revert) - ;; I temp disable undo for performance: since I'm going to clear the - ;; undo list, it can save more than a 9% of time with big - ;; directories because setting properties modify the undo-list. - (buffer-disable-undo) - (wdired-preprocess-files) - (if wdired-allow-to-change-permissions - (wdired-preprocess-perms)) - (if (fboundp 'make-symbolic-link) - (wdired-preprocess-symlinks)) - (buffer-enable-undo) ; Performance hack. See above. (set-buffer-modified-p nil) (setq buffer-undo-list nil) (run-mode-hooks 'wdired-mode-hook) @@ -264,6 +261,53 @@ See `wdired-mode'." "Press \\[wdired-finish-edit] when finished \ or \\[wdired-abort-changes] to abort changes"))) +(defun wdired--set-permission-bounds () + (save-excursion + (goto-char (point-min)) + (re-search-forward dired-re-perms nil t 1) + (goto-char (match-beginning 0)) + (setq-local wdired--perm-beg (current-column)) + (goto-char (match-end 0)) + (setq-local wdired--perm-end (current-column)))) + +(defun wdired--current-column () + (- (point) (line-beginning-position))) + +(defun wdired--point-at-perms-p () + (<= wdired--perm-beg (wdired--current-column) wdired--perm-end)) + +(defun wdired--line-preprocessed-p () + (get-text-property (line-beginning-position) 'front-sticky)) + +(defun wdired--self-insert () + (interactive) + (if (wdired--point-at-perms-p) + (unless (wdired--line-preprocessed-p) + (wdired--before-change-fn (line-beginning-position) (line-end-position)) + (wdired-toggle-bit)) + (call-interactively 'self-insert-command))) + +(defun wdired--before-change-fn (beg end) + (save-excursion + ;; make sure to process entire lines + (goto-char beg) + (setq beg (line-beginning-position)) + (goto-char end) + (setq end (line-end-position)) + + (while (< beg end) + (unless (wdired--line-preprocessed-p) + (put-text-property beg (1+ beg) 'front-sticky t) + (wdired--preprocess-files) + (when wdired-allow-to-change-permissions + (wdired--preprocess-perms)) + (when (fboundp 'make-symbolic-link) + (wdired--preprocess-symlinks))) + (forward-line) + (setq beg (point))) + ;; is this good enough? assumes no extra white lines from dired + (put-text-property (1- (point-max)) (point-max) 'read-only t))) + (defun wdired-isearch-filter-read-only (beg end) "Skip matches that have a read-only property." (not (text-property-not-all (min beg end) (max beg end) @@ -271,14 +315,12 @@ or \\[wdired-abort-changes] to abort changes"))) ;; Protect the buffer so only the filenames can be changed, and put ;; properties so filenames (old and new) can be easily found. -(defun wdired-preprocess-files () - (put-text-property (point-min) (1+ (point-min))'front-sticky t) +(defun wdired--preprocess-files () (save-excursion - (goto-char (point-min)) - (let ((b-protection (point)) - (used-F (dired-check-switches dired-actual-switches "F" "classify")) - filename) - (while (not (eobp)) + (with-silent-modifications + (beginning-of-line) + (let ((used-F (dired-check-switches dired-actual-switches "F" "classify")) + filename) (setq filename (dired-get-filename nil t)) (when (and filename (not (member (file-name-nondirectory filename) '("." "..")))) @@ -287,19 +329,16 @@ or \\[wdired-abort-changes] to abort changes"))) ;; the filename can't be modified. (add-text-properties (1- (point)) (point) `(old-name ,filename rear-nonsticky (read-only))) - (put-text-property b-protection (point) 'read-only t) + (put-text-property (- (point) 1) (point) 'read-only t) (dired-move-to-end-of-filename t) (put-text-property (point) (1+ (point)) 'end-name t)) - (when (and used-F (looking-at "[*/@|=>]$")) (forward-char)) - (when (save-excursion - (and (re-search-backward - dired-permission-flags-regexp nil t) - (looking-at "l") - (search-forward " -> " (line-end-position) t))) - (goto-char (line-end-position))) - (setq b-protection (point)) - (forward-line)) - (put-text-property b-protection (point-max) 'read-only t)))) + (when (and used-F (looking-at "[*/@|=>]$")) (forward-char)) + (when (save-excursion + (and (re-search-backward + dired-permission-flags-regexp nil t) + (looking-at "l") + (search-forward " -> " (line-end-position) t))) + (goto-char (line-end-position))))))) ;; This code is a copy of some dired-get-filename lines. (defsubst wdired-normalize-filename (file unquotep) @@ -362,7 +401,6 @@ non-nil means return old filename." (and file (> (length file) 0) (concat (dired-current-directory) file)))))) - (defun wdired-change-to-dired-mode () "Change the mode back to dired." (or (eq major-mode 'wdired-mode) @@ -380,16 +418,18 @@ non-nil means return old filename." (setq mode-name "Dired") (dired-advertise) (remove-hook 'kill-buffer-hook #'wdired-check-kill-buffer t) + (remove-hook 'before-change-functions #'wdired--before-change-fn t) (remove-hook 'after-change-functions #'wdired--restore-properties t) (remove-function (local 'revert-buffer-function) #'wdired-revert)) (defun wdired-abort-changes () "Abort changes and return to dired mode." (interactive) - (let ((inhibit-read-only t)) + (remove-hook 'before-change-functions 'wdired--before-change-fn t) + (with-silent-modifications (erase-buffer) - (insert wdired-old-content) - (goto-char wdired-old-point)) + (insert wdired--old-content) + (goto-char wdired--old-point)) (wdired-change-to-dired-mode) (set-buffer-modified-p nil) (setq buffer-undo-list nil) @@ -411,7 +451,7 @@ non-nil means return old filename." (setq errors (cdr tmp-value)) (setq changes (car tmp-value))) (when (and wdired-allow-to-change-permissions - (boundp 'wdired-col-perm)) ; could have been changed + (boundp 'wdired--col-perm)) ; could have been changed (setq tmp-value (wdired-do-perm-changes)) (setq errors (+ errors (cdr tmp-value))) (setq changes (or changes (car tmp-value)))) @@ -429,11 +469,11 @@ non-nil means return old filename." (let ((mark (cond ((integerp wdired-keep-marker-rename) wdired-keep-marker-rename) (wdired-keep-marker-rename - (cdr (assoc file-old wdired-old-marks))) + (cdr (assoc file-old wdired--old-marks))) (t nil)))) (when mark (push (cons (substitute-in-file-name file-new) mark) - wdired-old-marks)))) + wdired--old-marks)))) (push (cons file-old (substitute-in-file-name file-new)) files-renamed)))) (forward-line -1))) @@ -458,7 +498,7 @@ non-nil means return old filename." ;; Re-sort the buffer. (revert-buffer) (let ((inhibit-read-only t)) - (dired-mark-remembered wdired-old-marks))) + (dired-mark-remembered wdired--old-marks))) (let ((inhibit-read-only t)) (remove-text-properties (point-min) (point-max) '(old-name nil end-name nil old-link nil @@ -702,21 +742,19 @@ says how many lines to move; default is one line." (dired-move-to-filename))) ;; Put the needed properties to allow the user to change links' targets -(defun wdired-preprocess-symlinks () - (let ((inhibit-read-only t)) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (when (looking-at dired-re-sym) - (re-search-forward " -> \\(.*\\)$") - (put-text-property (1- (match-beginning 1)) - (match-beginning 1) 'old-link - (match-string-no-properties 1)) - (put-text-property (match-end 1) (1+ (match-end 1)) 'end-link t) - (unless wdired-allow-to-redirect-links - (put-text-property (match-beginning 0) - (match-end 1) 'read-only t))) - (forward-line))))) +(defun wdired--preprocess-symlinks () + (save-excursion + (with-silent-modifications + (beginning-of-line) + (when (looking-at dired-re-sym) + (re-search-forward " -> \\(.*\\)$") + (put-text-property (1- (match-beginning 1)) + (match-beginning 1) 'old-link + (match-string-no-properties 1)) + (put-text-property (match-end 1) (1+ (match-end 1)) 'end-link t) + (unless wdired-allow-to-redirect-links + (put-text-property (match-beginning 0) + (match-end 1) 'read-only t)))))) (defun wdired-get-previous-link (&optional old move) "Return the next symlink target. @@ -800,7 +838,6 @@ Like original function but it skips read-only words." (interactive "p") (wdired-xcase-word 'capitalize-word arg)) - ;; The following code deals with changing the access bits (or ;; permissions) of the files. @@ -822,34 +859,33 @@ Like original function but it skips read-only words." ;; Put a keymap property to the permission bits of the files, and store the ;; original name and permissions as a property -(defun wdired-preprocess-perms () - (let ((inhibit-read-only t)) - (setq-local wdired-col-perm nil) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (when (and (not (looking-at dired-re-sym)) - (wdired-get-filename) - (re-search-forward dired-re-perms (line-end-position) 'eol)) - (let ((begin (match-beginning 0)) - (end (match-end 0))) - (unless wdired-col-perm - (setq wdired-col-perm (- (current-column) 9))) - (if (eq wdired-allow-to-change-permissions 'advanced) - (progn - (put-text-property begin end 'read-only nil) - ;; make first permission bit writable - (put-text-property - (1- begin) begin 'rear-nonsticky '(read-only))) - ;; avoid that keymap applies to text following permissions - (add-text-properties - (1+ begin) end - `(keymap ,wdired-perm-mode-map rear-nonsticky (keymap)))) - (put-text-property end (1+ end) 'end-perm t) - (put-text-property - begin (1+ begin) 'old-perm (match-string-no-properties 0)))) - (forward-line) - (beginning-of-line))))) +(defun wdired--preprocess-perms () + (save-excursion + (with-silent-modifications + (setq-local wdired--col-perm nil) + (beginning-of-line) + (when (and (not (looking-at dired-re-sym)) + (wdired-get-filename) + (re-search-forward dired-re-perms + (line-end-position) 'eol)) + (let ((begin (match-beginning 0)) + (end (match-end 0))) + (unless wdired--col-perm + (setq wdired--col-perm (- (current-column) 9))) + (if (eq wdired-allow-to-change-permissions 'advanced) + (progn + (put-text-property begin end 'read-only nil) + ;; make first permission bit writable + (put-text-property + (1- begin) begin 'rear-nonsticky '(read-only))) + ;; avoid that keymap applies to text following permissions + (add-text-properties + (1+ begin) end + `(keymap ,wdired-perm-mode-map rear-nonsticky (keymap)))) + (put-text-property end (1+ end) 'end-perm t) + (put-text-property + begin (1+ begin) + 'old-perm (match-string-no-properties 0))))))) (defun wdired-perm-allowed-in-pos (char pos) (cond @@ -865,10 +901,10 @@ Like original function but it skips read-only words." "Set a permission bit character." (interactive) (if (wdired-perm-allowed-in-pos last-command-event - (- (current-column) wdired-col-perm)) + (- (current-column) wdired--col-perm)) (let ((new-bit (char-to-string last-command-event)) (inhibit-read-only t) - (pos-prop (- (point) (- (current-column) wdired-col-perm)))) + (pos-prop (- (point) (- (current-column) wdired--col-perm)))) (put-text-property 0 1 'keymap wdired-perm-mode-map new-bit) (put-text-property 0 1 'read-only t new-bit) (insert new-bit) @@ -882,11 +918,11 @@ Like original function but it skips read-only words." (interactive) (let ((inhibit-read-only t) (new-bit "-") - (pos-prop (- (point) (- (current-column) wdired-col-perm)))) + (pos-prop (- (point) (- (current-column) wdired--col-perm)))) (if (eq (char-after (point)) ?-) (setq new-bit - (if (= (% (- (current-column) wdired-col-perm) 3) 0) "r" - (if (= (% (- (current-column) wdired-col-perm) 3) 1) "w" + (if (= (% (- (current-column) wdired--col-perm) 3) 0) "r" + (if (= (% (- (current-column) wdired--col-perm) 3) 1) "w" "x")))) (put-text-property 0 1 'keymap wdired-perm-mode-map new-bit) (put-text-property 0 1 'read-only t new-bit) commit 47ec253a5d7c6b9ae3dd988cdcdcf88b015e5e8e Author: Michael Albinus Date: Sat Mar 27 12:49:00 2021 +0100 ; Adapt recent change in test/infra/gitlab-ci.yml diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index d91c3a411e..c957bf9b4d 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -95,8 +95,6 @@ default: artifacts: expire_in: 24 hrs paths: [] - # - "test/**/*.log" - # - "**/*.log" # using the variables for each job script: - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} @@ -135,9 +133,12 @@ default: .test-template: artifacts: + name: ${CI_JOB_NAME}-${CI_COMMIT_SHA} + public: true expire_in: 1 week + when: always paths: - - "test/**/*.log" + - "**/*.log" .gnustep-template: rules: commit d6344b2e9a1edb384770ceba757779dca49158d2 Author: Michael Albinus Date: Sat Mar 27 11:43:15 2021 +0100 Keep *.log files on emba * test/infra/gitlab-ci.yml (.test-template): New template. (test-fast-inotify, test-lisp-inotify, test-lisp-net-inotify) (test-filenotify-gio, test-gnustep, test-all-inotify): Use it. diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba index cde657aada..30a5897134 100644 --- a/test/infra/Dockerfile.emba +++ b/test/infra/Dockerfile.emba @@ -47,7 +47,8 @@ RUN make -j4 FROM emacs-base as emacs-filenotify-gio RUN apt-get update && \ - apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 libglib2.0-dev libglib2.0-bin libglib2.0-0 \ + apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ + libglib2.0-dev libglib2.0-bin libglib2.0-0 \ && rm -rf /var/lib/apt/lists/* COPY . /checkout diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 5a0ab54e4b..d91c3a411e 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -133,6 +133,12 @@ default: - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba . - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} +.test-template: + artifacts: + expire_in: 1 week + paths: + - "test/**/*.log" + .gnustep-template: rules: - if: '$CI_PIPELINE_SOURCE == "web"' @@ -185,7 +191,7 @@ build-image-inotify: test-fast-inotify: stage: fast - extends: [.job-template] + extends: [.job-template, .test-template] variables: target: emacs-inotify make_params: "-C test check" @@ -204,14 +210,14 @@ build-image-gnustep: test-lisp-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] variables: target: emacs-inotify make_params: "-C test check-lisp" test-lisp-net-inotify: stage: normal - extends: [.job-template] + extends: [.job-template, .test-template] variables: target: emacs-inotify make_params: "-C test check-lisp-net" @@ -219,7 +225,7 @@ test-lisp-net-inotify: test-filenotify-gio: # This tests file monitor libraries gfilemonitor and gio. stage: platforms - extends: [.job-template, .filenotify-gio-template] + extends: [.job-template, .test-template, .filenotify-gio-template] variables: target: emacs-filenotify-gio make_params: "-k -C test autorevert-tests filenotify-tests" @@ -227,7 +233,7 @@ test-filenotify-gio: test-gnustep: # This tests the GNUstep build process stage: platforms - extends: [.job-template, .gnustep-template] + extends: [.job-template, .test-template, .gnustep-template] variables: target: emacs-gnustep make_params: install @@ -235,7 +241,7 @@ test-gnustep: test-all-inotify: # This tests also file monitor libraries inotify and inotifywatch. stage: slow - extends: [.job-template] + extends: [.job-template, .test-template] rules: # note there's no "changes" section, so this always runs on a schedule - if: '$CI_PIPELINE_SOURCE == "web"' commit a25a5a68b44888c2c7b581250e54a0c9820b5975 Author: Eli Zaretskii Date: Sat Mar 27 13:24:58 2021 +0300 Fix lisp/files-tests on MS-Windows * test/lisp/files-tests.el (files-colon-path) (files-tests-bug-21454): Adapt to MS-DOS/Windows, where parse-colon-path needs and absolute file name with a drive letter. (files-tests-file-name-non-special-get-file-buffer): Forcefully delete the file's buffer if it happens to exist. diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 149cc689ae..33716577a1 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -192,14 +192,37 @@ form.") (ert-deftest files-tests-bug-21454 () "Test for https://debbugs.gnu.org/21454 ." (let ((input-result - '(("/foo/bar//baz/:/bar/foo/baz//" nil ("/foo/bar/baz/" "/bar/foo/baz/")) - ("/foo/bar/:/bar/qux/:/qux/foo" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) - ("//foo/bar/:/bar/qux/:/qux/foo/" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) - ("/foo/bar/:/bar/qux/:/qux/foo/" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) - ("/foo//bar/:/bar/qux/:/qux/foo/" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) - ("/foo//bar/:/bar/qux/:/qux/foo" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) - ("/foo/bar" "$FOO/baz/:/qux/foo/" ("/foo/bar/baz/" "/qux/foo/")) - ("//foo/bar/" "$FOO/baz/:/qux/foo/" ("/foo/bar/baz/" "/qux/foo/")))) + (if (memq system-type '(windows-nt ms-dos)) + '(("x:/foo/bar//baz/;y:/bar/foo/baz//" nil + ("x:/foo/bar/baz/" "y:/bar/foo/baz/")) + ("x:/foo/bar/;y:/bar/qux/;z:/qux/foo" nil + ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) + ("x://foo/bar/;y:/bar/qux/;z:/qux/foo/" nil + ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) + ("x:/foo/bar/;y:/bar/qux/;z:/qux/foo/" nil + ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) + ("x:/foo//bar/;y:/bar/qux/;z:/qux/foo/" nil + ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) + ("x:/foo//bar/;y:/bar/qux/;z:/qux/foo" nil + ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) + ("x:/foo/bar" "$FOO/baz/;z:/qux/foo/" + ("x:/foo/bar/baz/" "z:/qux/foo/")) + ("x://foo/bar/" "$FOO/baz/;z:/qux/foo/" + ("x:/foo/bar/baz/" "z:/qux/foo/"))) + '(("/foo/bar//baz/:/bar/foo/baz//" nil + ("/foo/bar/baz/" "/bar/foo/baz/")) + ("/foo/bar/:/bar/qux/:/qux/foo" nil + ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("//foo/bar/:/bar/qux/:/qux/foo/" nil + ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo/bar/:/bar/qux/:/qux/foo/" nil + ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo//bar/:/bar/qux/:/qux/foo/" nil + ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo//bar/:/bar/qux/:/qux/foo" nil + ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo/bar" "$FOO/baz/:/qux/foo/" ("/foo/bar/baz/" "/qux/foo/")) + ("//foo/bar/" "$FOO/baz/:/qux/foo/" ("/foo/bar/baz/" "/qux/foo/"))))) (foo-env (getenv "FOO")) (bar-env (getenv "BAR"))) (unwind-protect @@ -857,10 +880,15 @@ unquoted file names." (find-backup-file-name tmpfile))))))) (ert-deftest files-tests-file-name-non-special-get-file-buffer () + ;; Make sure these buffers don't exist. (files-tests--with-temp-non-special (tmpfile nospecial) - (should-not (get-file-buffer nospecial))) + (let ((fbuf (get-file-buffer nospecial))) + (if fbuf (kill-buffer fbuf)) + (should-not (get-file-buffer nospecial)))) (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) - (should-not (get-file-buffer nospecial)))) + (let ((fbuf (get-file-buffer nospecial))) + (if fbuf (kill-buffer fbuf)) + (should-not (get-file-buffer nospecial))))) (ert-deftest files-tests-file-name-non-special-insert-directory () (files-tests--with-temp-non-special (tmpdir nospecial-dir t) @@ -1363,8 +1391,11 @@ See ." (should (not (eq major-mode 'text-mode)))))) (ert-deftest files-colon-path () - (should (equal (parse-colon-path "/foo//bar/baz") - '("/foo/bar/baz/")))) + (if (memq system-type '(windows-nt ms-dos)) + (should (equal (parse-colon-path "x:/foo//bar/baz") + '("x:/foo/bar/baz/"))) + (should (equal (parse-colon-path "/foo//bar/baz") + '("/foo/bar/baz/"))))) (ert-deftest files-test-magic-mode-alist-doctype () "Test that DOCTYPE and variants put files in mhtml-mode." commit c4ab173df3ea4c37165c011c515928da1783a9ae Author: Matt Armstrong Date: Fri Feb 19 15:39:15 2021 -0800 File unlock errors now issue warnings (Bug#46397) The primary idea is to allow `kill-buffer' and `kill-emacs' to complete even if Emacs has trouble unlocking the buffer's file. * lisp/userlock.el (userlock--handle-unlock-error): New function, call `display-error'. * src/filelock.c (unlock_file_body): New function, do what 'unlock_file' used to. (unlock_file_handle_error): New function, call `userlock--handle-unlock-error' with the captured error. (unlock_file): Handle `file-error' conditions by calling the handler defined above. * test/src/filelock-tests.el (filelock-tests-kill-buffer-spoiled): (filelock-tests-unlock-spoiled): Modify to test new behavior. diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index 2828b50cad..a8b921eb9f 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -764,6 +764,8 @@ This function unlocks the file being visited in the current buffer, if the buffer is modified. If the buffer is not modified, then the file should not be locked, so this function does nothing. It also does nothing if the current buffer is not visiting a file, or is not locked. +This function handles file system errors by calling @code{display-warning} +and otherwise ignores the error. @end defun @defopt create-lockfiles diff --git a/etc/NEWS b/etc/NEWS index 68812c64cc..2d66a93474 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2501,6 +2501,12 @@ back in Emacs 23.1. The affected functions are: 'make-obsolete', * Lisp Changes in Emacs 28.1 ++++ +** 'unlock-buffer' displays warnings instead of signaling. +Instead of signaling 'file-error' conditions for file system level +errors, the function now calls 'display-warning' and continues as if +the error did not occur. + +++ ** New function 'always'. This is identical to 'ignore', but returns t instead. diff --git a/lisp/userlock.el b/lisp/userlock.el index 57311ac99c..4a75815318 100644 --- a/lisp/userlock.el +++ b/lisp/userlock.el @@ -224,4 +224,14 @@ to get the latest version of the file, then make the change again." revert-buffer-binding)) (help-mode))))) +;;;###autoload +(defun userlock--handle-unlock-error (error) + "Report an ERROR that occurred while unlocking a file." + (display-warning + '(unlock-file) + ;; There is no need to explain that this is an unlock error because + ;; ERR is a `file-error' condition, which explains this. + (message "%s, ignored" (error-message-string error)) + :warning)) + ;;; userlock.el ends here diff --git a/src/filelock.c b/src/filelock.c index 373fc00a42..446a262a1c 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -719,8 +719,8 @@ lock_file (Lisp_Object fn) } } -void -unlock_file (Lisp_Object fn) +static Lisp_Object +unlock_file_body (Lisp_Object fn) { char *lfname; USE_SAFE_ALLOCA; @@ -737,6 +737,23 @@ unlock_file (Lisp_Object fn) report_file_errno ("Unlocking file", filename, err); SAFE_FREE (); + return Qnil; +} + +static Lisp_Object +unlock_file_handle_error (Lisp_Object err) +{ + call1 (intern ("userlock--handle-unlock-error"), err); + return Qnil; +} + +void +unlock_file (Lisp_Object fn) +{ + internal_condition_case_1 (unlock_file_body, + fn, + list1(Qfile_error), + unlock_file_handle_error); } #else /* MSDOS */ @@ -790,7 +807,10 @@ DEFUN ("unlock-buffer", Funlock_buffer, Sunlock_buffer, 0, 0, 0, doc: /* Unlock the file visited in the current buffer. If the buffer is not modified, this does nothing because the file -should not be locked in that case. */) +should not be locked in that case. It also does nothing if the +current buffer is not visiting a file, or is not locked. Handles file +system errors by calling `display-warning' and continuing as if the +error did not occur. */) (void) { if (SAVE_MODIFF < MODIFF diff --git a/test/src/filelock-tests.el b/test/src/filelock-tests.el index c6f55efd49..a96d6d6728 100644 --- a/test/src/filelock-tests.el +++ b/test/src/filelock-tests.el @@ -138,11 +138,16 @@ the case)." (should-not (file-locked-p buffer-file-truename)) (filelock-tests--spoil-lock-file buffer-file-truename) - ;; FIXME: Unlocking buffers should not signal errors related to - ;; their lock files (bug#46397). - (let ((err (should-error (unlock-buffer)))) - (should (equal (cl-subseq err 0 2) - '(file-error "Unlocking file"))))))) + ;; 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\"." @@ -161,13 +166,18 @@ the case)." ;; a function that fakes a "yes" answer for the "Buffer modified; ;; kill anyway?" prompt. ;; - ;; FIXME: Killing buffers should not signal errors related to - ;; their lock files (bug#46397). - (let* ((err (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (&rest _) t))) - (should-error (kill-buffer))))) - (should (equal (seq-subseq err 0 2) - '(file-error "Unlocking file"))))))) + ;; 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 commit a443a379c54158f49efd8542632c4e9478aa1117 Author: Matt Armstrong Date: Mon Feb 15 12:59:08 2021 -0800 Add test coverage for src/filelock.c (Bug#46397) * test/src/filelock-tests.el: New file. diff --git a/test/src/filelock-tests.el b/test/src/filelock-tests.el new file mode 100644 index 0000000000..c6f55efd49 --- /dev/null +++ b/test/src/filelock-tests.el @@ -0,0 +1,173 @@ +;;; 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 . + +;;; 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) + + ;; FIXME: Unlocking buffers should not signal errors related to + ;; their lock files (bug#46397). + (let ((err (should-error (unlock-buffer)))) + (should (equal (cl-subseq err 0 2) + '(file-error "Unlocking file"))))))) + +(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. + ;; + ;; FIXME: Killing buffers should not signal errors related to + ;; their lock files (bug#46397). + (let* ((err (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (&rest _) t))) + (should-error (kill-buffer))))) + (should (equal (seq-subseq err 0 2) + '(file-error "Unlocking file"))))))) + +(provide 'filelock-tests) +;;; filelock-tests.el ends here