[PATCH] Support for Sqlite Archive files

[Vladimir Kazanov <vekazanov@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 446 bytes --]

Hi all,

Sqlite Archive files are a format similar to archive but using Sqlite
database as an underlying format. See https://sqlite.org/sqlar.html
for details.

Included is a patch for archive-mode  that adds a backend utilising
the sqlite3 cli utility for inspecting and editing sqlar files. The
code includes a set of unit tests as well as an example sqlar file.

Happy to hear feedback on the addition.

Thanks

-- 
Regards,

Vladimir Kazanov

[-- Attachment #2: v1-0001-Support-for-Sqlite-Archives.patch --]
[-- Type: text/x-patch, Size: 14097 bytes --]

From 24bbfa983dddae7437cdc653494b91c6e8ffaca6 Mon Sep 17 00:00:00 2001
From: Vladimir Kazanov <vekazanov@gmail.com>
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.
+
 \f
 * 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 <wbrodie@panix.com> 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_<MFd1g@&1CW=gd85!h2qeT;(#ewAsIp`*#IDfOrjQ0^Qbvg
z`fkw}(f&^|NfwW`#^^KF?Gw_cw?8F(H-9}%3$|_3n<>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