emacs/test/lisp/arc-mode-tests.el

;;; arc-mode-tests.el --- Test suite for arc-mode. -*- lexical-binding: t -*-

;; Copyright (C) 2017-2025 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Code:
(require 'ert)
(require 'arc-mode)

(defvar arc-mode-tests-data-directory
  (expand-file-name "test/data/decompress" source-directory))

(ert-deftest arc-mode-test-archive-int-to-mode ()
  (let ((alist (list (cons 448 "-rwx------")
                     (cons 420 "-rw-r--r--")
                     (cons 292 "-r--r--r--")
                     (cons 512 "---------T")
                     (cons 1024 "------S---") ; Bug#28092
                     (cons 2048 "---S------"))))
    (dolist (x alist)
      (should (equal (cdr x) (file-modes-number-to-symbolic (car x)))))))

(ert-deftest arc-mode-test-zip-extract-gz ()
  (skip-unless (and archive-zip-extract (executable-find (car archive-zip-extract))))
  (skip-unless (executable-find "gzip"))
  (let* ((zip-file (expand-file-name "zg.zip" arc-mode-tests-data-directory))
         zip-buffer gz-buffer)
    (unwind-protect
        (with-current-buffer (setq zip-buffer (find-file-noselect zip-file))
          (setq gz-buffer (archive-extract))
          (should (equal (char-after) ?\N{SNOWFLAKE})))
      (when (buffer-live-p zip-buffer) (kill-buffer zip-buffer))
      (when (buffer-live-p gz-buffer) (kill-buffer gz-buffer)))))

(declare-function tar-extract "tar-mode")
(ert-deftest arc-mode-test-zip-extract-tar-and-gz ()
  (skip-unless (and archive-zip-extract (executable-find (car archive-zip-extract))))
  (skip-unless (executable-find "gzip"))
  (require 'tar-mode)
  (let* ((zip-file (expand-file-name "ztg.zip" arc-mode-tests-data-directory))
         zip-buffer tar-buffer gz-buffer)
    (unwind-protect
        (with-current-buffer (setq zip-buffer (find-file-noselect zip-file))
          (with-current-buffer (setq tar-buffer (archive-extract))
            (setq gz-buffer (tar-extract))
            (should (equal (char-after) ?\N{SNOWFLAKE}))))
      (when (buffer-live-p zip-buffer) (kill-buffer zip-buffer))
      (when (buffer-live-p tar-buffer) (kill-buffer tar-buffer))
      (when (buffer-live-p gz-buffer) (kill-buffer gz-buffer)))))

(defun arc-mode-test-make-file (name)
  "Create file NAME in default directory with content NAME.
Return NAME."
  (with-temp-buffer
    (insert name)
    (write-file name))
  name)

(defun arc-mode-test-make-archive (command arc files)
  "Call COMMAND to create archive ARC containing FILES.
Return a cons (ARC . EXIT-STATUS)."
  (unless (listp command)
    (setq command (list command)))
  (delete-file arc nil)
  (cons arc (funcall (archive--act-files command files) arc)))

(defmacro define-arc-mode-test-on-type (name command extension type)
  "Define a test that tests function `archive-find-type'.
Name the test based on NAME.  The generated test first calls

  (call-process (car COMMAND) nil nil nil
                (append COMMAND (list ARCHIVE MEMBER)))

to create file ARCHIVE with extension EXTENSION and containing a single
member MEMBER.  Then the test finds ARCHIVE and ensures that function
`archive-find-type' detects it as an archive having type TYPE."
  (let* ((command (eval command))
         (argv0   (car command))
         (type    (eval type)))
    `(ert-deftest ,(intern (format "arc-mode-test-type-%s" name)) ()
       (skip-unless (executable-find ,argv0))
       (let ((default-directory arc-mode-tests-data-directory)
             (member nil) (archive nil) (buffer nil)
             result exit-status type)
         (unwind-protect
             (progn
               (setq member (arc-mode-test-make-file "member")
                     result (arc-mode-test-make-archive
                             (quote ,command) ,(format "arc.%s" extension) (list member))
                     archive (car result)
                     exit-status (cdr result))
               ;; do not count archiver errors as test failures
               (skip-unless (eq exit-status 0))
               (with-current-buffer
                   (setq buffer (find-file-literally archive))
                 (setq type (condition-case err
                                (archive-find-type)
                              (error
                               ;; turn the most likely error into a nice
                               ;; and self-explaining symbol that can be
                               ;; compared in a `should'
                               (if (string= (cadr err) "Buffer format not recognized")
                                   'signature-not-recognized
                                 (signal (car err) (cdr err))))))
                 (should (eq type (quote ,type)))))
           (when buffer (kill-buffer buffer))
           (dolist (file (list member archive))
             (when file (ignore-errors (delete-file file)))))))))

(define-arc-mode-test-on-type "zip" '("zip") "zip" 'zip)

(define-arc-mode-test-on-type "split-zip" '("zip" "-s1") "zip" 'zip)

(define-arc-mode-test-on-type "arc" '("arc" "a") "arc" 'arc)

(define-arc-mode-test-on-type "lha" '("lha" "a") "lzh" 'lzh)

(define-arc-mode-test-on-type "rar" '("rar" "a") "rar" 'rar)

(define-arc-mode-test-on-type "ar" '("ar" "q") "a" 'ar)

;; prefer executable "7z" to "7za", since the former seems be supported
;; on a broader range of ports
(define-arc-mode-test-on-type "7z" '("7z" "a") "7z" '7z)

(ert-deftest arc-mode-test-zip-ensure-ext ()
  "Regression test for bug#61326."
  (skip-unless (executable-find "zip"))
  (let* ((default-directory arc-mode-tests-data-directory)
         (created-files nil)
         (base-zip-1 "base-1.zip")
         (base-zip-2 "base-2.zip")
         (content-1 '("1" "2"))
         (content-2 '("3" "4"))
         (update-fn
          (lambda (zip-nonempty)
            (with-current-buffer (find-file-noselect zip-nonempty)
              (save-excursion
                (goto-char archive-file-list-start)
                (save-current-buffer
                  (archive-extract)
                  (save-excursion
                    (goto-char (point-max))
                    (insert ?a)
                    (save-buffer))
                  (kill-buffer (current-buffer)))
                (archive-extract)
                ;; [2] must be ?a; [3] must be (eobp)
                (should (eq (char-after 2) ?a))
                (should (eq (point-max) 3))))))
         (delete-fn
          (lambda (zip-nonempty)
            (with-current-buffer (find-file-noselect zip-nonempty)
              ;; mark delete and expunge first entry
              (save-excursion
                (goto-char archive-file-list-start)
                (should (length= archive-files 2))
                (archive-flag-deleted 1)
                (archive--expunge-maybe-force t)
                (should (length= archive-files 1))))))
         (test-modify
          (lambda (zip mod-fn)
            (let ((zip-base (concat zip ".zip"))
                  (tag (gensym)))
              (push zip created-files)
              (copy-file base-zip-1 zip t)
              (push zip-base created-files)
              (copy-file base-zip-2 zip-base t)
              (file-has-changed-p zip tag)
              (file-has-changed-p zip-base tag)
              (funcall mod-fn zip)
              (should-not (file-has-changed-p zip-base tag))
              (should (file-has-changed-p zip tag))))))
    (unwind-protect
        (progn
          ;; setup: make two zip files with different contents
          (dolist (file (append content-1 content-2))
            (push (arc-mode-test-make-file file) created-files))
          (push (car (arc-mode-test-make-archive "zip" base-zip-1 content-1))
                created-files)
          (push (car (arc-mode-test-make-archive "zip" base-zip-2 content-2))
                created-files)

          ;; test 1: with "test-update" and "test-update.zip", update
          ;; "test-update": (1) ensure only "test-update" is modified, (2)
          ;; ensure the contents of the new member is expected.
          (funcall test-modify "test-update" update-fn)

          ;; test 2: with "test-delete" and "test-delete.zip", delete entry
          ;; from "test-delete": (1) ensure only "test-delete" is modified,
          ;; (2) ensure the file list is reduced as expected.
          (funcall test-modify "test-delete" delete-fn))

      ;; Clean up created files.
      (dolist (file created-files)
        (ignore-errors (delete-file file))))))

(provide 'arc-mode-tests)

;;; arc-mode-tests.el ends here