;;; 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.

;; Note: many of these tests set file modes to unusual values, with
;; the aim of exercising Emacs' error handling code.  These tests
;; require POSIX file system semantics, which are not available on all
;; file systems (e.g. FAT, NTFS).  The tests skip themselves when the
;; file system does not support the given file modes.

;;; Code:

(require 'cl-lib)
(require 'ert)

(defvar filelock-tests-temporary-file-directory nil
  "The directory for writing temporary files in filelock tests.
This is used by the function
`filelock-tests--make-temp-directory' to override the value of
the variable `temporary-file-directory'.")

(defun filelock-tests--make-temp-directory ()
  "Create and return the name of a temporary directory.
The caller should delete the directory."
  (let ((temporary-file-directory (or filelock-tests-temporary-file-directory
                                      temporary-file-directory)))
    (make-temp-file "test" t)))

(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.  Call TEST-FUNCTION,
passing it directory name.  Finally, delete the buffer and the
test directory.

This function attempts to delete the test directory even if the
test leaves the buffer locked or the test directory with strange
permissions."
  (let* ((temp-dir (filelock-tests--make-temp-directory))
         (name (concat (file-name-as-directory temp-dir)
                       "file"))
         (create-lockfiles t))
    (unwind-protect
        (with-temp-buffer
          (setq buffer-file-name name)
          (setq buffer-file-truename name)
          (unwind-protect
              (save-current-buffer
                (funcall test-function temp-dir))

            ;; Here begins somewhat delicate cleanup logic.  It must
            ;; be performed in this order.
            ;;
            ;; First, give Emacs permission to modify the test
            ;; directory.  The test may have left the diretory's modes
            ;; in an unusual state.
            ;;
            ;; Second, mark the buffer unmodified.  This prevents
            ;; prompts from `kill-buffer' about saving unmodified
            ;; buffers (when this test is run interactively).
            ;;
            ;; Third, delete the temp buffer (by way of
            ;; `with-temp-buffer' above).  Emacs may also delete the
            ;; lock file from the test directory at this point.
            ;;
            ;; Fourth, delete the test directory itself.

            (set-file-modes temp-dir (logior #o700 (file-modes temp-dir)))
            (set-buffer-modified-p nil)))
      (delete-directory temp-dir t nil))))

(defun filelock-tests--make-file-inaccessible (filename)
  "Make file named FILENAME inaccessible.
Returns non-nil if the operation succeeds, otherwise nil.  Note:
not all file systems support this operation."
  (set-file-modes filename #o000)
  (equal #o000 (file-modes filename)))

(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))))
     (insert "this locks the buffer's file")
     (should (file-locked-p (buffer-file-name)))
     (unlock-buffer)
     (should (not (file-locked-p (buffer-file-name)))))))

(ert-deftest filelock-tests-lock-buffer-permission-denied ()
  "Check that locking a buffer in a directory with no write
permissions does not work."
  (filelock-tests--fixture
   (lambda (temp-dir)
     (should (not (file-locked-p (buffer-file-name))))

     (let ((original-modes (file-modes temp-dir)))
       (skip-unless (filelock-tests--make-file-inaccessible temp-dir))
       ;; FIXME: file system errors when locking a file are ignored;
       ;; should they be?
       (insert "this locks the current buffer's file")
       (set-file-modes temp-dir original-modes))

     (should (not (file-locked-p (buffer-file-name)))))))

(ert-deftest filelock-tests-file-locked-p-permission-denied ()
  "Check that `file-locked-p' fails if the directory is inaccesible."
  (filelock-tests--fixture
   (lambda (temp-dir)
     (skip-unless (filelock-tests--make-file-inaccessible temp-dir))

     (let ((err (should-error (file-locked-p (buffer-file-name)))))
       (should (equal (cl-subseq err 0 2)
                      '(file-error "Testing file lock")))))))

(ert-deftest filelock-tests-unlock-permission-denied ()
  "Check that `unlock-buffer' fails in directories that cannot be
modified."
  (filelock-tests--fixture
   (lambda (temp-dir)
     (insert "this locks the current buffer's file")
     (should (file-locked-p (buffer-file-name)))

     (skip-unless (filelock-tests--make-file-inaccessible temp-dir))

     ;; 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")))))))

(defun filelock-tests--yes (&rest _)
  "Return t."
  t)

(ert-deftest filelock-tests-kill-buffer-permission-denied ()
  "Check that `unlock-buffer' fails in directories that cannot be
modified."
  (filelock-tests--fixture
   (lambda (temp-dir)
     (insert "this should lock the buffer")
     (should (file-locked-p (buffer-file-name)))

     (skip-unless (filelock-tests--make-file-inaccessible temp-dir))

     ;; Kill the current buffer even if it is modified.  Use advice to
     ;; fake a "yes" answer for the "Buffer modified; kill anyway?"
     ;; prompt.  Leave the buffer modified so `kill-buffer' will
     ;; attempt to unlock the buffer's file.
     ;;
     ;; FIXME: Killing buffers should not signal errors related to
     ;; their lock files (bug#46397).
     (let ((err (unwind-protect
                    (progn
                      (advice-add 'yes-or-no-p
                                  :override
                                  'filelock-tests--yes)
                      (should-error (kill-buffer)))
                  (advice-remove 'yes-or-no-p 'filelock-tests--yes))))
       (should (equal (cl-subseq err 0 2)
                      '(file-error "Unlocking file")))))))

(provide 'filelock-tests)
;;; filelock-tests.el ends here