[Emacs-diffs] master a17f30d: Add MIME apps spec utilities

[Mark Oteiza]

branch: master
commit a17f30d7cdfa3983f8c97e474015777ec051de35
Author: Mark Oteiza <address@hidden>
Commit: Mark Oteiza <address@hidden>

    Add MIME apps spec utilities
    
    Facilitates finding associations between MIME types and desktop files
    that report an association with that type.  Combined with mailcap.el's
    MIME facilities, it should be easy to use desktop files.
    * lisp/xdg.el (xdg-mime-table): New variable.
    (xdg-mime-apps-files, xdg-mime-collect-associations, xdg-mime-apps):
    New functions.
    * test/data/xdg/mimeapps.list: New file.
    * test/data/xdg/mimeinfo.cache: New file.
    * test/lisp/xdg-tests.el (xdg-mime-associations): New test.
---
 lisp/xdg.el                  | 103 +++++++++++++++++++++++++++++++++++++++++++
 test/data/xdg/mimeapps.list  |   9 ++++
 test/data/xdg/mimeinfo.cache |   4 ++
 test/lisp/xdg-tests.el       |  12 +++++
 4 files changed, 128 insertions(+)

diff --git a/lisp/xdg.el b/lisp/xdg.el
index 76106f4..4250faa 100644
--- a/lisp/xdg.el
+++ b/lisp/xdg.el
@@ -34,6 +34,7 @@
 ;;; Code:
 
 (eval-when-compile
+  (require 'cl-lib)
   (require 'subr-x))
 
 
@@ -212,6 +213,108 @@ Optional argument GROUP defaults to the string \"Desktop 
Entry\"."
     (when (null (string-match-p "[^[:blank:]]" (car res))) (pop res))
     (nreverse res)))
 
+
+;; MIME apps specification
+;; https://standards.freedesktop.org/mime-apps-spec/mime-apps-spec-1.0.1.html
+
+(defvar xdg-mime-table nil
+  "Table of MIME type to desktop file associations.
+The table is an alist with keys being MIME major types (\"application\",
+\"audio\", etc.), and values being hash tables.  Each hash table has
+MIME subtypes as keys and lists of desktop file absolute filenames.")
+
+(defun xdg-mime-apps-files ()
+  "Return a list of files containing MIME/Desktop associations.
+The list is in order of descending priority: user config, then
+admin config, and finally system cached associations."
+  (let ((xdg-data-dirs (xdg-data-dirs))
+        (desktop (getenv "XDG_CURRENT_DESKTOP"))
+        res)
+    (when desktop
+      (setq desktop (format "%s-mimeapps.list" desktop)))
+    (dolist (name (cons "mimeapps.list" desktop))
+      (push (expand-file-name name (xdg-config-home)) res)
+      (push (expand-file-name (format "applications/%s" name) (xdg-data-home))
+            res)
+      (dolist (dir (xdg-config-dirs))
+        (push (expand-file-name name dir) res))
+      (dolist (dir xdg-data-dirs)
+        (push (expand-file-name (format "applications/%s" name) dir) res)))
+    (dolist (dir xdg-data-dirs)
+      (push (expand-file-name "applications/mimeinfo.cache" dir) res))
+    (nreverse res)))
+
+(defun xdg-mime-collect-associations (mime files)
+  "Return a list of desktop file names associated with MIME.
+The associations are searched in the list of file names FILES,
+which is expected to be ordered by priority as in
+`xdg-mime-apps-files'."
+  (let ((regexp (concat (regexp-quote mime) "=\\([^[:cntrl:]]*\\)$"))
+        res sec defaults added removed cached)
+    (with-temp-buffer
+      (dolist (f (reverse files))
+        (when (file-readable-p f)
+          (insert-file-contents-literally f nil nil nil t)
+          (goto-char (point-min))
+          (let (end)
+            (while (not (or (eobp) end))
+              (if (= (following-char) ?\[)
+                  (progn (setq sec (char-after (1+ (point))))
+                         (forward-line))
+                (if (not (looking-at regexp))
+                    (forward-line)
+                  (dolist (str (xdg-desktop-strings (match-string 1)))
+                    (cl-pushnew str
+                                (cond ((eq sec ?D) defaults)
+                                      ((eq sec ?A) added)
+                                      ((eq sec ?R) removed)
+                                      ((eq sec ?M) cached))
+                                :test #'equal))
+                  (while (and (zerop (forward-line))
+                              (/= (following-char) ?\[)))))))
+          ;; Accumulate results into res
+          (dolist (f cached)
+            (when (not (member f removed)) (cl-pushnew f res :test #'equal)))
+          (dolist (f added)
+            (when (not (member f removed)) (push f res)))
+          (dolist (f removed)
+            (setq res (delete f res)))
+          (dolist (f defaults)
+            (push f res))
+          (setq defaults nil added nil removed nil cached nil))))
+    (delete-dups res)))
+
+(defun xdg-mime-apps (mime)
+  "Return list of desktop files associated with MIME, otherwise nil.
+The list is in order of descending priority, and each element is
+an absolute file name of a readable file.
+Results are cached in `xdg-mime-table'."
+  (pcase-let ((`(,type ,subtype) (split-string mime "/"))
+              (xdg-data-dirs (xdg-data-dirs))
+              (caches (xdg-mime-apps-files))
+              (files ()))
+    (let ((mtim1 (get 'xdg-mime-table 'mtime))
+          (mtim2 (cl-loop for f in caches when (file-readable-p f)
+                          maximize (float-time (nth 5 (file-attributes f))))))
+      ;; If one of the MIME/Desktop cache files has been modified:
+      (when (or (null mtim1) (time-less-p mtim1 mtim2))
+        (setq xdg-mime-table nil)))
+    (when (null (assoc type xdg-mime-table))
+      (push (cons type (make-hash-table :test #'equal)) xdg-mime-table))
+    (if (let ((def (make-symbol "def"))
+              (table (cdr (assoc type xdg-mime-table))))
+          (not (eq (setq files (gethash subtype table def)) def)))
+        files
+      (and files (setq files nil))
+      (let ((dirs (mapcar (lambda (dir) (expand-file-name "applications" dir))
+                          (cons (xdg-data-home) xdg-data-dirs))))
+        ;; Not being particular about desktop IDs
+        (dolist (f (nreverse (xdg-mime-collect-associations mime caches)))
+          (push (locate-file f dirs) files))
+        (when files
+          (put 'xdg-mime-table 'mtime (current-time)))
+        (puthash subtype (delq nil files) (cdr (assoc type 
xdg-mime-table)))))))
+
 (provide 'xdg)
 
 ;;; xdg.el ends here
diff --git a/test/data/xdg/mimeapps.list b/test/data/xdg/mimeapps.list
new file mode 100644
index 0000000..27fbd94
--- /dev/null
+++ b/test/data/xdg/mimeapps.list
@@ -0,0 +1,9 @@
+[Default Applications]
+x-test/foo=a.desktop
+
+[Added Associations]
+x-test/foo=b.desktop
+x-test/baz=a.desktop
+
+[Removed Associations]
+x-test/foo=c.desktop;d.desktop
diff --git a/test/data/xdg/mimeinfo.cache b/test/data/xdg/mimeinfo.cache
new file mode 100644
index 0000000..6e54f60
--- /dev/null
+++ b/test/data/xdg/mimeinfo.cache
@@ -0,0 +1,4 @@
+[MIME Cache]
+x-test/foo=c.desktop;d.desktop
+x-test/bar=a.desktop;c.desktop
+x-test/baz=b.desktop;d.desktop
diff --git a/test/lisp/xdg-tests.el b/test/lisp/xdg-tests.el
index b80f5e8..eaf03ab 100644
--- a/test/lisp/xdg-tests.el
+++ b/test/lisp/xdg-tests.el
@@ -65,4 +65,16 @@
   (should (equal (xdg-desktop-strings " ") nil))
   (should (equal (xdg-desktop-strings "a; ;") '("a" " "))))
 
+(ert-deftest xdg-mime-associations ()
+  "Test reading MIME associations from files."
+  (let* ((apps (expand-file-name "mimeapps.list" xdg-tests-data-dir))
+         (cache (expand-file-name "mimeinfo.cache" xdg-tests-data-dir))
+         (fs (list apps cache)))
+    (should (equal (xdg-mime-collect-associations "x-test/foo" fs)
+                   '("a.desktop" "b.desktop")))
+    (should (equal (xdg-mime-collect-associations "x-test/bar" fs)
+                   '("a.desktop" "c.desktop")))
+    (should (equal (xdg-mime-collect-associations "x-test/baz" fs)
+                   '("a.desktop" "b.desktop" "d.desktop")))))
+
 ;;; xdg-tests.el ends here