lisp/xdg.el

   1 ;;; xdg.el --- XDG specification and standard support -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2017-2018 Free Software Foundation, Inc.
   4
   5 ;; Author: Mark Oteiza <mvoteiza@udel.edu>
   6 ;; Created: 27 January 2017
   7 ;; Keywords: files, data
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published
  13 ;; by the Free Software Foundation; either version 3 of the License,
  14 ;; or (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Library providing some convenience functions for the following XDG
  27 ;; standards and specifications
  28 ;;
  29 ;; - XDG Base Directory Specification
  30 ;; - Thumbnail Managing Standard
  31 ;; - xdg-user-dirs configuration
  32 ;; - Desktop Entry Specification
  33
  34 ;;; Code:
  35
  36 (eval-when-compile
  37   (require 'cl-lib)
  38   (require 'subr-x))
  39
  40 \f
  41 ;; XDG Base Directory Specification
  42 ;; https://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
  43
  44 (defmacro xdg--dir-home (environ default-path)
  45   (declare (debug (stringp stringp)))
  46   (let ((env (make-symbol "env")))
  47     `(let ((,env (getenv ,environ)))
  48        (if (or (null ,env) (not (file-name-absolute-p ,env)))
  49            (expand-file-name ,default-path)
  50          ,env))))
  51
  52 (defun xdg-config-home ()
  53   "Return the base directory for user specific configuration files."
  54   (xdg--dir-home "XDG_CONFIG_HOME" "~/.config"))
  55
  56 (defun xdg-cache-home ()
  57   "Return the base directory for user specific cache files."
  58   (xdg--dir-home "XDG_CACHE_HOME" "~/.cache"))
  59
  60 (defun xdg-data-home ()
  61   "Return the base directory for user specific data files."
  62   (xdg--dir-home "XDG_DATA_HOME" "~/.local/share"))
  63
  64 (defun xdg-runtime-dir ()
  65   "Return the value of $XDG_RUNTIME_DIR."
  66   (getenv "XDG_RUNTIME_DIR"))
  67
  68 (defun xdg-config-dirs ()
  69   "Return the config directory search path as a list."
  70   (let ((env (getenv "XDG_CONFIG_DIRS")))
  71     (if (or (null env) (string= env ""))
  72         '("/etc/xdg")
  73       (parse-colon-path env))))
  74
  75 (defun xdg-data-dirs ()
  76   "Return the data directory search path as a list."
  77   (let ((env (getenv "XDG_DATA_DIRS")))
  78     (if (or (null env) (string= env ""))
  79         '("/usr/local/share/" "/usr/share/")
  80       (parse-colon-path env))))
  81
  82 \f
  83 ;; Thumbnail Managing Standard
  84 ;; https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html
  85
  86 (defun xdg-thumb-uri (filename)
  87   "Return the canonical URI for FILENAME.
  88 If FILENAME has absolute file name /foo/bar.jpg, its canonical URI is
  89 file:///foo/bar.jpg"
  90   (concat "file://" (expand-file-name filename)))
  91
  92 (defun xdg-thumb-name (filename)
  93   "Return the appropriate thumbnail filename for FILENAME."
  94   (concat (md5 (xdg-thumb-uri filename)) ".png"))
  95
  96 (defun xdg-thumb-mtime (filename)
  97   "Return modification time of FILENAME as an Emacs timestamp."
  98   (file-attribute-modification-time (file-attributes filename)))
  99
 100 \f
 101 ;; XDG User Directories
 102 ;; https://www.freedesktop.org/wiki/Software/xdg-user-dirs/
 103
 104 (defconst xdg-line-regexp
 105   (eval-when-compile
 106     (rx "XDG_"
 107         (group-n 1 (or "DESKTOP" "DOWNLOAD" "TEMPLATES" "PUBLICSHARE"
 108                        "DOCUMENTS" "MUSIC" "PICTURES" "VIDEOS"))
 109         "_DIR=\""
 110         (group-n 2 (or "/" "$HOME/") (*? (or (not (any "\"")) "\\\"")))
 111         "\""))
 112   "Regexp matching non-comment lines in xdg-user-dirs config files.")
 113
 114 (defvar xdg-user-dirs nil
 115   "Alist of directory keys and values.")
 116
 117 (defun xdg--substitute-home-env (str)
 118   (if (file-name-absolute-p str) str
 119     (save-match-data
 120       (and (string-match "^$HOME/" str)
 121            (replace-match "~/" t nil str 0)))))
 122
 123 (defun xdg--user-dirs-parse-line ()
 124   "Return pair of user-dirs key to directory value in LINE, otherwise nil.
 125 This should be called at the beginning of a line."
 126   (skip-chars-forward "[:blank:]")
 127   (when (and (/= (following-char) ?#)
 128              (looking-at xdg-line-regexp))
 129     (let ((k (match-string 1))
 130           (v (match-string 2)))
 131       (when (and k v) (cons k (xdg--substitute-home-env v))))))
 132
 133 (defun xdg--user-dirs-parse-file (filename)
 134   "Return alist of xdg-user-dirs from FILENAME."
 135   (let (elt res)
 136     (when (file-readable-p filename)
 137       (with-temp-buffer
 138         (insert-file-contents filename)
 139         (goto-char (point-min))
 140         (while (not (eobp))
 141           (setq elt (xdg--user-dirs-parse-line))
 142           (when (consp elt) (push elt res))
 143           (forward-line))))
 144     res))
 145
 146 (defun xdg-user-dir (name)
 147   "Return the directory referred to by NAME."
 148   (when (null xdg-user-dirs)
 149     (setq xdg-user-dirs
 150           (xdg--user-dirs-parse-file
 151            (expand-file-name "user-dirs.dirs" (xdg-config-home)))))
 152   (let ((dir (cdr (assoc name xdg-user-dirs))))
 153     (when dir (expand-file-name dir))))
 154
 155 \f
 156 ;; Desktop Entry Specification
 157 ;; https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-1.1.html
 158
 159 (defconst xdg-desktop-group-regexp
 160   (rx "[" (group-n 1 (+? (in " -Z\\^-~"))) "]")
 161   "Regexp matching desktop file group header names.")
 162
 163 ;; TODO Localized strings left out intentionally, as Emacs has no
 164 ;; notion of l10n/i18n
 165 (defconst xdg-desktop-entry-regexp
 166   (rx (group-n 1 (+ (in "A-Za-z0-9-")))
 167       ;; (? "[" (group-n 3 (+ nonl)) "]")
 168       (* blank) "=" (* blank)
 169       (group-n 2 (* nonl)))
 170   "Regexp matching desktop file entry key-value pairs.")
 171
 172 (defun xdg-desktop-read-group ()
 173   "Return hash table of group of desktop entries in the current buffer."
 174   (let ((res (make-hash-table :test #'equal)))
 175     (while (not (or (eobp) (looking-at xdg-desktop-group-regexp)))
 176       (skip-chars-forward "[:blank:]")
 177       (cond
 178        ((eolp))
 179        ((= (following-char) ?#))
 180        ((looking-at xdg-desktop-entry-regexp)
 181         (puthash (match-string 1) (match-string 2) res))
 182        ;; Filter localized strings
 183        ((looking-at (rx (group-n 1 (+ (in alnum "-"))) (* blank) "[")))
 184        (t (error "Malformed line: %s"
 185                  (buffer-substring (point) (point-at-eol)))))
 186       (forward-line))
 187     res))
 188
 189 (defun xdg-desktop-read-file (filename &optional group)
 190   "Return group contents of desktop file FILENAME as a hash table.
 191 Optional argument GROUP defaults to the string \"Desktop Entry\"."
 192   (with-temp-buffer
 193     (insert-file-contents-literally filename)
 194     (goto-char (point-min))
 195     (while (and (skip-chars-forward "[:blank:]" (line-end-position))
 196                 (or (eolp) (= (following-char) ?#)))
 197       (forward-line))
 198     (unless (looking-at xdg-desktop-group-regexp)
 199       (error "Expected group name!  Instead saw: %s"
 200              (buffer-substring (point) (point-at-eol))))
 201     (when group
 202       (while (and (re-search-forward xdg-desktop-group-regexp nil t)
 203                   (not (equal (match-string 1) group)))))
 204     (forward-line)
 205     (xdg-desktop-read-group)))
 206
 207 (defun xdg-desktop-strings (value)
 208   "Partition VALUE into elements delimited by unescaped semicolons."
 209   (let (res)
 210     (setq value (string-trim-left value))
 211     (dolist (x (split-string (replace-regexp-in-string "\\\\;" "\0" value) ";"))
 212       (push (replace-regexp-in-string "\0" ";" x) res))
 213     (when (null (string-match-p "[^[:blank:]]" (car res))) (pop res))
 214     (nreverse res)))
 215
 216 \f
 217 ;; MIME apps specification
 218 ;; https://standards.freedesktop.org/mime-apps-spec/mime-apps-spec-1.0.1.html
 219
 220 (defvar xdg-mime-table nil
 221   "Table of MIME type to desktop file associations.
 222 The table is an alist with keys being MIME major types (\"application\",
 223 \"audio\", etc.), and values being hash tables.  Each hash table has
 224 MIME subtypes as keys and lists of desktop file absolute filenames.")
 225
 226 (defun xdg-mime-apps-files ()
 227   "Return a list of files containing MIME/Desktop associations.
 228 The list is in order of descending priority: user config, then
 229 admin config, and finally system cached associations."
 230   (let ((xdg-data-dirs (xdg-data-dirs))
 231         (desktop (getenv "XDG_CURRENT_DESKTOP"))
 232         res)
 233     (when desktop
 234       (setq desktop (format "%s-mimeapps.list" desktop)))
 235     (dolist (name (cons "mimeapps.list" desktop))
 236       (push (expand-file-name name (xdg-config-home)) res)
 237       (push (expand-file-name (format "applications/%s" name) (xdg-data-home))
 238             res)
 239       (dolist (dir (xdg-config-dirs))
 240         (push (expand-file-name name dir) res))
 241       (dolist (dir xdg-data-dirs)
 242         (push (expand-file-name (format "applications/%s" name) dir) res)))
 243     (dolist (dir xdg-data-dirs)
 244       (push (expand-file-name "applications/mimeinfo.cache" dir) res))
 245     (nreverse res)))
 246
 247 (defun xdg-mime-collect-associations (mime files)
 248   "Return a list of desktop file names associated with MIME.
 249 The associations are searched in the list of file names FILES,
 250 which is expected to be ordered by priority as in
 251 `xdg-mime-apps-files'."
 252   (let ((regexp (concat (regexp-quote mime) "=\\([^[:cntrl:]]*\\)$"))
 253         res sec defaults added removed cached)
 254     (with-temp-buffer
 255       (dolist (f (reverse files))
 256         (when (file-readable-p f)
 257           (insert-file-contents-literally f nil nil nil t)
 258           (goto-char (point-min))
 259           (let (end)
 260             (while (not (or (eobp) end))
 261               (if (= (following-char) ?\[)
 262                   (progn (setq sec (char-after (1+ (point))))
 263                          (forward-line))
 264                 (if (not (looking-at regexp))
 265                     (forward-line)
 266                   (dolist (str (xdg-desktop-strings (match-string 1)))
 267                     (cl-pushnew str
 268                                 (cond ((eq sec ?D) defaults)
 269                                       ((eq sec ?A) added)
 270                                       ((eq sec ?R) removed)
 271                                       ((eq sec ?M) cached))
 272                                 :test #'equal))
 273                   (while (and (zerop (forward-line))
 274                               (/= (following-char) ?\[)))))))
 275           ;; Accumulate results into res
 276           (dolist (f cached)
 277             (when (not (member f removed)) (cl-pushnew f res :test #'equal)))
 278           (dolist (f added)
 279             (when (not (member f removed)) (push f res)))
 280           (dolist (f removed)
 281             (setq res (delete f res)))
 282           (dolist (f defaults)
 283             (push f res))
 284           (setq defaults nil added nil removed nil cached nil))))
 285     (delete-dups res)))
 286
 287 (defun xdg-mime-apps (mime)
 288   "Return list of desktop files associated with MIME, otherwise nil.
 289 The list is in order of descending priority, and each element is
 290 an absolute file name of a readable file.
 291 Results are cached in `xdg-mime-table'."
 292   (pcase-let ((`(,type ,subtype) (split-string mime "/"))
 293               (xdg-data-dirs (xdg-data-dirs))
 294               (caches (xdg-mime-apps-files))
 295               (files ()))
 296     (let ((mtim1 (get 'xdg-mime-table 'mtime))
 297           (mtim2 (cl-loop for f in caches when (file-readable-p f)
 298                           maximize (float-time
 299                                     (file-attribute-modification-time
 300                                      (file-attributes f))))))
 301       ;; If one of the MIME/Desktop cache files has been modified:
 302       (when (or (null mtim1) (time-less-p mtim1 mtim2))
 303         (setq xdg-mime-table nil)))
 304     (when (null (assoc type xdg-mime-table))
 305       (push (cons type (make-hash-table :test #'equal)) xdg-mime-table))
 306     (if (let ((def (make-symbol "def"))
 307               (table (cdr (assoc type xdg-mime-table))))
 308           (not (eq (setq files (gethash subtype table def)) def)))
 309         files
 310       (and files (setq files nil))
 311       (let ((dirs (mapcar (lambda (dir) (expand-file-name "applications" dir))
 312                           (cons (xdg-data-home) xdg-data-dirs))))
 313         ;; Not being particular about desktop IDs
 314         (dolist (f (nreverse (xdg-mime-collect-associations mime caches)))
 315           (push (locate-file f dirs) files))
 316         (when files
 317           (put 'xdg-mime-table 'mtime (current-time)))
 318         (puthash subtype (delq nil files) (cdr (assoc type xdg-mime-table)))))))
 319
 320 (provide 'xdg)
 321
 322 ;;; xdg.el ends here