From 24bbfa983dddae7437cdc653494b91c6e8ffaca6 Mon Sep 17 00:00:00 2001 From: Vladimir Kazanov Date: Fri, 21 Jun 2024 11:53:45 +0100 Subject: [PATCH v1] Support for Sqlite Archives Include an archive-mode backend for Sqlite Archive (sqlar) files viewing and editing. * lisp/arc-mode.el (archive-sqlar-summarize, archive-sqlar-extract, archive-sqlar-write-file-member): Add the backend. * lisp/files.el: Register the extension. * test/data/decompress/test.sqlar: Test file. * test/lisp/arc-mode-tests.el: Tests for the backend. --- etc/NEWS | 6 ++ lisp/arc-mode.el | 153 +++++++++++++++++++++++++++++--- lisp/files.el | 1 + test/data/decompress/test.sqlar | Bin 0 -> 3584 bytes test/lisp/arc-mode-tests.el | 86 ++++++++++++++++++ 5 files changed, 235 insertions(+), 11 deletions(-) create mode 100644 test/data/decompress/test.sqlar diff --git a/etc/NEWS b/etc/NEWS index e9507e80d1f..4a5c9636f07 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1981,6 +1981,12 @@ The following new XML schemas are now supported: Typing 'C-u M-x ping' prompts first for the host, and then for the flags to give to "ping". +--- +** Archive mode now supports editing Sqlite Archive files +If the sqlite3 utility is present in the environment it is now possible +to view and edit contents of the Sqlite Archive file format (*.sqlar) +through the Archive mode. + * New Modes and Packages in Emacs 30.1 diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index bf9def681c3..dbb568281e1 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -51,17 +51,17 @@ ;; ARCHIVE TYPES: Currently only the archives below are handled, but the ;; structure for handling just about anything is in place. ;; -;; Arc Lzh Zip Zoo Rar 7z Ar Squashfs -;; --------------------------------------------------------------- -;; View listing Intern Intern Intern Intern Y Y Y Y -;; Extract member Y Y Y Y Y Y Y Y -;; Save changed member Y Y Y Y N Y Y N -;; Add new member N N N N N N N N -;; Delete member Y Y Y Y N Y N N -;; Rename member Y Y N N N N N N -;; Chmod - Y Y - N N N N -;; Chown - Y - - N N N N -;; Chgrp - Y - - N N N N +;; Arc Lzh Zip Zoo Rar 7z Ar Squashfs Sqlar +;; ----------------------------------------------------------------------------- +;; View listing Intern Intern Intern Intern Y Y Y Y Y +;; Extract member Y Y Y Y Y Y Y Y Y +;; Save changed member Y Y Y Y N Y Y N Y +;; Add new member N N N N N N N N N +;; Delete member Y Y Y Y N Y N N Y +;; Rename member Y Y N N N N N N N +;; Chmod - Y Y - N N N N N +;; Chown - Y - - N N N N N +;; Chgrp - Y - - N N N N N ;; ;; Special thanks to Bill Brodie for very useful tips ;; on the first released version of this package. @@ -401,6 +401,57 @@ archive-squashfs-extract :version "28.1" :group 'archive-squashfs) +;; ------------------------------ +;; Sqlite Archive configuration + +(defgroup archive-sqlar nil + "Sqlite Archive options to archive." + :group 'archive) + +(defcustom archive-sqlar-summarize + '("sqlite3" "-A" "--list" "--verbose" "--file") + "Program and its options to run in order to list Sqlite Archive +file members." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :version "29.1" + :group 'archive-sqlar) + +(defcustom archive-sqlar-expunge + '("sqlite3" "-A" "--remove" "--file") + "Program and its options to run in order to delete Sqlite Archive +file members." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :version "29.1" + :group 'archive-sqlar) + +(defcustom archive-sqlar-write-file-member + '("sqlite3" "-A" "--update" "--file") + "Program and its options to run in order to delete Sqlite Archive +file members." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :version "29.1" + :group 'archive-sqlar) + +(defcustom archive-sqlar-extract + '("sqlite3" "-A" "--extract" "--file") + "Program and its options to run in order to extract Sqlite Archive +file members." + :type '(list (string :tag "Program") + (repeat :tag "Options" + :inline t + (string :format "%v"))) + :version "29.1" + :group 'archive-sqlar) + ;; ------------------------------------------------------------------------- ;;; Section: Variables @@ -811,6 +862,7 @@ archive-find-type 'rar-exe) ((looking-at "7z\274\257\047\034") '7z) ((looking-at "hsqs") 'squashfs) + ((looking-at "SQLite format 3") 'sqlar) (t (error "Buffer format not recognized"))))) ;; ------------------------------------------------------------------------- @@ -2482,6 +2534,85 @@ archive-squashfs-extract-by-stdout (defun archive-squashfs-extract (archive name) (archive-squashfs-extract-by-stdout archive name archive-squashfs-extract)) +;; ------------------------------------------------------------------------- +;;; Section Sqlite Archives. + +(defun archive-sqlar-summarize (&optional file) + (unless file (setq file buffer-file-name)) + (let* ((copy (file-local-copy file)) + (files ())) + (with-temp-buffer + (unwind-protect + (apply #'call-process + (car archive-sqlar-summarize) + nil t nil + (append (cdr archive-sqlar-summarize) + (list (or file copy)))) + (if copy (delete-file copy))) + (goto-char (point-min)) + (while (looking-at (concat "^\\(.[rwx\\-]\\{9\\}\\)\s+" ; Mode + "\\([0-9-]+\\)\s+" ; Size + "\\([0-9-]+\\)\s+" ; Date + "\\([0-9:]+\\)\s+" ; Time + "\\(.*\\)\n" ; Name + )) + (goto-char (match-end 0)) + (let ((flags (match-string 1)) + (size (match-string 2)) + (name (match-string 5)) + (datetime (concat (match-string 3) " " (match-string 4))) + mode) + (setq mode (file-modes-symbolic-to-number + (concat + "u=" (string-replace "-" "" (substring flags 1 4)) + ",g=" (string-replace "-" "" (substring flags 4 7)) + ",o=" (string-replace "-" "" (substring flags 7 10))))) + (push (archive--file-desc name name + mode + (string-to-number size) + datetime) + files)))) + (archive--summarize-descs (nreverse files)))) + +;; NOTE: a simplified version of archive-*-extract without archive +;; directory stripping (or parametrise archive-*-extract) +(defun archive-sqlar-extract (archive name) + (when (file-name-absolute-p name) + (error "Can't extract files with non-relative names")) + + (let* ((default-directory (file-name-as-directory archive-tmpdir)) + (tmpfile (expand-file-name name default-directory)) + exit-status success) + (make-directory (directory-file-name default-directory) t) + (setq exit-status + (apply #'call-process + (car archive-sqlar-extract) + nil + nil + nil + (append (cdr archive-sqlar-extract) (list archive name)))) + (cond ((and (numberp exit-status) (zerop exit-status)) + (if (not (file-exists-p tmpfile)) + (ding (message "`%s': no such file or directory" tmpfile)) + (insert-file-contents tmpfile) + (setq success t))) + ((numberp exit-status) + (ding + (message "`%s' exited with status %d" (car archive-sqlar-extract) exit-status))) + ((stringp exit-status) + (ding (message "`%s' aborted: %s" (car archive-sqlar-extract) exit-status))) + (t + (ding (message "`%s' failed" (car archive-sqlar-extract))))) + (archive-delete-local tmpfile) + success)) + +(defun archive-sqlar-write-file-member (archive descr) + (archive-*-write-file-member + archive + descr + archive-sqlar-write-file-member)) + + ;; ------------------------------------------------------------------------- ;; This line was a mistake; it is kept now for compatibility. ;; rms 15 Oct 98 diff --git a/lisp/files.el b/lisp/files.el index 042b8e2d515..891b8d86212 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -3021,6 +3021,7 @@ auto-mode-alist ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\|SQUASHFS\\)\\'" . archive-mode) ("\\.oxt\\'" . archive-mode) ;(Open|Libre)Office extensions. ("\\.\\(deb\\|[oi]pk\\)\\'" . archive-mode) ; Debian/Opkg packages. + ("\\.sqlar\\'" . archive-mode) ;Sqlite Archive files ;; Mailer puts message to be edited in ;; /tmp/Re.... or Message ("\\`/tmp/Re" . text-mode) diff --git a/test/data/decompress/test.sqlar b/test/data/decompress/test.sqlar new file mode 100644 index 0000000000000000000000000000000000000000..3675f7baf74aadb831e608c9e6df983963fcaaeb GIT binary patch literal 3584 zcmeHJOG^VW5Kh|K>f)=XJxFzKTJV90coJ-757qjr3+k!FZK{EN=q82Io8r&uv42DG z9|)cWuYwmRQ4fov7Y_RkeJ(G37Mmfn*>EbZ18${S zcff?^EP#*&99-wvh5bftr_wlqZRcbjU}52HDr$o|$Gr=mBRYs$9BR8R0uq8~=6PI7 zxZrUhq!dvoHC_oU|2YBiK9fq<6K&x!g?P|d%#pn>5^y!liDGdkLgt%xK#HEmx0qs3 zt?yM69T~hA1s5@P#arM-q2i&k%H>SnUbiU`VT*T>20Ym&>!`^1O~Xrb*_bTyJgm7M zL(R|uq4#t^Uvwmuzs^8;B0rnW(K*GXTGGR!>MC+IXm^~o@kG#?$>mE3olc-uA4fiX z%c4(s{&$2v;E>9{XP}s!rHLyrF`6xzh`uEH8880(J*FE-8AuuURR;8bK>zjh12Ocg OmD6G=11ST4mVsCPi;t23 literal 0 HcmV?d00001 diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el index 5ebc56a84fc..e54e8e7e54d 100644 --- a/test/lisp/arc-mode-tests.el +++ b/test/lisp/arc-mode-tests.el @@ -19,6 +19,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'arc-mode) (defvar arc-mode-tests-data-directory @@ -141,6 +142,91 @@ arc-mode-test-zip-ensure-ext (dolist (file created-files) (ignore-errors (delete-file file)))))) +;;; Sqlite Archive tests + +(ert-deftest arc-mode-test-sqlar-summarize () + (skip-unless (executable-find (car archive-sqlar-summarize))) + (let ((file (expand-file-name "test.sqlar" arc-mode-tests-data-directory)) + buf) + ;; The archive contains 2 files, let's check the results buffer + (unwind-protect + (with-current-buffer (setq buf (find-file-noselect file)) + (should (search-forward "test.txt")) + (should (search-forward "test/test.txt")) + (should (search-forward "2 files"))) + (when (buffer-live-p buf) (kill-buffer buf))))) + +(ert-deftest arc-mode-test-sqlar-extract () + (skip-unless (executable-find (car archive-sqlar-extract))) + (let ((file (expand-file-name "test.sqlar" arc-mode-tests-data-directory)) + buf innerbuf) + ;; Check a if extraction works for a file within the archive + (unwind-protect + (with-current-buffer (setq buf (find-file-noselect file)) + ;; Find the line with a file name + (should (search-forward "test/test.txt")) + ;; Open the file, check contents + (setq innerbuf (archive-extract)) + (should (search-forward "test/test.txt"))) + (when (buffer-live-p buf) (kill-buffer buf)) + (when (buffer-live-p innerbuf) (kill-buffer innerbuf))))) + +(ert-deftest arc-mode-test-sqlar-write-file-member () + (skip-unless (executable-find (car archive-sqlar-write-file-member))) + (ert-with-temp-directory tmpdir + (let* ((origfname (expand-file-name "test.sqlar" arc-mode-tests-data-directory)) + (tmpfname (expand-file-name "test.sqlar" tmpdir)) + buf innertbuf) + ;; create a copy of the test archvie + (copy-file origfname tmpfname) + + ;; Update the copy by removing all content of a file within the + ;; archive. + (unwind-protect + (with-current-buffer (setq buf (find-file-noselect tmpfname)) + (should (search-forward "test/test.txt")) + (setq innerbuf (archive-extract)) + (should (search-forward "test/test.txt")) + (should (> (buffer-size) 1)) + (delete-region (point-min) (point-max)) + (save-buffer)) + (when (buffer-live-p buf) (kill-buffer buf)) + (when (buffer-live-p innerbuf) (kill-buffer innerbuf))) + + ;; Open the file again and make sure the contents are not there. + (unwind-protect + (with-current-buffer (setq buf (find-file-noselect tmpfname)) + (should (search-forward "test/test.txt")) + (setq innerbuf (archive-extract)) + ;; there should be NOTHING + (should (eql (buffer-size) 0))) + (when (buffer-live-p buf) (kill-buffer buf)) + (when (buffer-live-p innerbuf) (kill-buffer innerbuf)))))) + +(ert-deftest arc-mode-test-sqlar-expunge () + (skip-unless (executable-find (car archive-sqlar-expunge))) + (ert-with-temp-directory tmpdir + (let* ((origfname (expand-file-name "test.sqlar" arc-mode-tests-data-directory)) + (tmpfname (expand-file-name "test.sqlar" tmpdir)) + buf) + ;; create a copy of the test archvie + (copy-file origfname tmpfname) + + ;; Remove a file from the archive + (unwind-protect + (with-current-buffer (setq buf (find-file-noselect tmpfname)) + (should (search-forward "test/test.txt")) + (archive-*-expunge tmpfname '("test/test.txt") archive-sqlar-expunge)) + (when (buffer-live-p buf) (kill-buffer buf))) + + ;; Open the file again and make sure the file is not there + (unwind-protect + (with-current-buffer (setq buf (find-file-noselect tmpfname)) + (should-not (search-forward "test/test.txt" nil t))) + (when (buffer-live-p buf) (kill-buffer buf)))))) + + + (provide 'arc-mode-tests) ;;; arc-mode-tests.el ends here -- 2.34.1