When diredfl is on, my custom setting to hide symlink target for git-annex gets broken.
(use-package git-annex
:hook (before-save . my-maybe-unlock-file)
:bind (:map dired-mode-map
("% a" . jmm/dired-mark-files-git-annex-matching)
:map git-annex-dired-map
("l" . git-annex-dired-lock-files)
("u" . git-annex-dired-unlock-files)
("f" . magit-annex-file-action)
("t" . jmm/dired-git-annex-tag)
("s" . jmm/dired-git-annex-print-human-file-size)
("S" . jmm/dired-git-annex-add-real-file-sizes)
("*")
("* u" . jmm/dired-mark-git-annex-unavailable-files))
:config
(defun my-file-writable-p (orig-fun file-name)
(let ((file-list (list file-name)))
(or (apply orig-fun file-list)
(let ((target (nth 0 (file-attributes file-name))))
(and (stringp target)
(string-match "\\.git/annex/" target))))))
(advice-add 'file-writable-p :around #'my-file-writable-p)
(setq git-annex-commit nil)
(git-annex-dired-do-to-files "drop" "Annex: dropped %d file(s)")
(git-annex-dired-do-to-files "edit" "Annex: unlocked %d file(s) for editing")
(git-annex-dired-do-to-files "get" "Annex: got %d file(s)")
(git-annex-dired-do-to-files "lock" "Annex: lock %d file(s)" t)
(defun my-maybe-unlock-file (&optional ARG)
(when (and buffer-file-name
(file-symlink-p buffer-file-name)
(string= (vc-backend buffer-file-name) "Git"))
(let ((target (nth 0 (file-attributes buffer-file-name))))
(assert (stringp target))
(when (string-match "\\.git/annex/" target)
(call-process "git-annex" nil nil nil "edit"
(file-relative-name buffer-file-name default-directory))))))
(defun jmm/git-annex-find-files (&rest args)
"Generate a list of git annex files that match ARGS.
For example, ARGS could be \"--in=here\""
(-remove #'s-blank?
(s-split "\0"
(shell-command-to-string (mapconcat #'identity
(append '("git annex find --print0") args)
" ")))))
(defun eshell/dga (&rest args)
"Show a `dired' buffer of git annex files that match ARGS.
For example, ARGS could be \"--in=here\""
(dired (cons "." (apply #'jmm/git-annex-find-files args))))
(defun eshell/gaf (&rest args)
"Return a list of git annex files that match ARGS.
For example, ARGS could be \"--in=here\""
(apply #'jmm/git-annex-find-files args))
(defvar-local jmm/git-annex-directory-tags nil
"Current git-annex tags set in the directory, as a list.")
(defun jmm/dired-git-annex-current-tags (file-list &optional intersection)
"Get current git-annex tag for each file in FILE-LIST. With
optional argument INTERSECTION, only show tags all files share in common."
(let* ((metadata (with-output-to-string
(with-current-buffer
standard-output
(apply #'process-file "git" nil t nil "annex" "metadata" "--json" file-list))))
(json-array-type 'list)
(jsonout (-map 'json-read-from-string (split-string metadata "\n" t))))
(-reduce (if intersection '-intersection '-union) (--map (cdr (assoc 'tag (cdr (assoc 'fields it)))) jsonout))))
(defun jmm/dired-git-annex-tag (file-list tags &optional arg)
"Add git-annex TAGS to each file in FILE-LIST.
Used as an interactive command, prompt for a list of tags for all
files, showing the current tags all files currently have in common."
(interactive
(let* ((files (dired-get-marked-files t current-prefix-arg))
(shared-tags (jmm/dired-git-annex-current-tags files t))
;; Cache directory tags
(current-tags (or jmm/git-annex-directory-tags
(setq jmm/git-annex-directory-tags
(or (jmm/dired-git-annex-current-tags '("--all")) '("")))))
(crm-separator " ")
(crm-local-completion-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map crm-local-completion-map)
(define-key map " " 'self-insert-command)
map))
(tags (completing-read-multiple
"Tags: " (--map (concat it crm-separator) current-tags)
nil nil
(when shared-tags (mapconcat 'identity shared-tags " ")))))
(setq jmm/git-annex-directory-tags (-union tags jmm/git-annex-directory-tags))
(list files tags current-prefix-arg)))
(let ((args (cl-loop for x in tags
append (list "-t" x))))
(-each file-list
(lambda (file)
(apply #'call-process "git" nil nil nil "annex" "metadata" (append args (list file)))))
(message (format "Tagged %d file(s)" (length file-list)))))
(defun jmm/dired-mark-git-annex-unavailable-files ()
"Mark git-annex files that are not present."
(interactive)
(dired-mark-if
(and (looking-at-p ".* -> \\(.*\\.git/annex/.+\\)")
(not (file-exists-p (file-truename (dired-get-filename t)))))
"unavailable file"))
(defun jmm/dired-mark-files-git-annex-matching (matchingoptions &optional marker-char)
"Mark all files that match git annex's MATCHINGOPTIONS for use in later commands.
A prefix argument means to unmark them instead.
`.' and `..' are never marked."
(interactive
(list (read-string (concat (if current-prefix-arg "Unmark" "Mark")
" files matching (git annex match expression): ")
nil 'jmm-dired-annex-matchingoptions-history)
(if current-prefix-arg ?\040)))
(let ((dired-marker-char (or marker-char dired-marker-char)))
(dired-mark-if
(and (not (looking-at-p dired-re-dot))
(not (eolp)) ; empty line
(let ((fn (dired-get-filename nil t)))
(when (and fn (not (file-directory-p fn)))
(message "Checking %s" fn)
(s-present? (shell-command-to-string
(mapconcat
#'identity
(list "git annex find" matchingoptions (shell-quote-argument fn))
" "))))))
"matching file")))
(defun jmm/git-annex-file-target (filename)
"If FILENAME is a git annex file, return its symlink target."
(-when-let (symname (and filename
(file-symlink-p filename)))
(when (string-match-p ".*\\.git/annex/.+" symname)
symname)))
(defun jmm/dired-git-annex-file-target ()
"If the dired file at point is a git annex file, return its symlink target."
(jmm/git-annex-file-target (dired-get-filename nil t)))
(defun jmm/git-annex-file-size (filename)
"Try to determine the size of the git annex file FILENAME."
(-when-let (target (jmm/git-annex-file-target filename))
(or (save-match-data
(when (string-match "SHA256E-s\\([0-9]+\\)--" target)
(string-to-number (match-string 1 target))))
(-some-> (expand-file-name target (file-name-directory filename))
file-attributes
file-attribute-size))))
(defun jmm/dired-git-annex-print-human-file-size ()
"Try to print the human readable file size of the dired git-annex file at point."
(interactive)
(let* ((filename (dired-get-filename nil t))
(string-file (file-name-nondirectory filename)))
(-if-let (filesize (-some-> (jmm/git-annex-file-size filename)
file-size-human-readable))
(message "%s - %s" filesize string-file)
(message "Can't determine git annex file size of %s" string-file))))
(defun jmm/dired-git-annex-add-real-file-sizes ()
"Go through all the git-annex files in dired, replace the
symlink file size with the real file size, then try to align
everything."
(interactive)
(require 'dired-aux)
(let ((regexp directory-listing-before-filename-regexp))
(save-excursion
(goto-char (point-min))
(dired-goto-next-file)
(while (or (dired-move-to-filename)
(progn (save-restriction
(narrow-to-region (dired-subdir-min) (dired-subdir-max))
(dired--align-all-files))
(dired-next-subdir 1 t)
(dired-goto-next-file)
(dired-move-to-filename)))
(let ((inhibit-read-only t))
(when (and (jmm/dired-git-annex-file-target)
(re-search-backward regexp (line-beginning-position) t))
(goto-char (match-beginning 0))
(-when-let (newsize (-some-> (jmm/git-annex-file-size (dired-get-filename nil t))
file-size-human-readable))
(search-backward-regexp "[[:space:]]" nil t)
(when (re-search-forward "[[:space:]]+\\([^[:space:]]+\\)[[:space:]]" nil t)
(goto-char (match-beginning 1))
(delete-region (point) (match-end 1))
(insert-and-inherit newsize))))
(forward-line))))))
(defun jmm/dired-dir-files-beginning ()
"First point where there's a filename on the line. Beginning of line."
(save-excursion
(goto-char (dired-subdir-min))
(dired-goto-next-file)
(beginning-of-line)
(point)))
(defun jmm/dired-dir-files-end ()
"Last point where there's a filename. End of line."
(save-excursion
(goto-char (dired-subdir-max))
(while (not (dired-get-filename nil t))
(dired-previous-line nil))
(end-of-line)
(point)))
(defun jmm/dired-file-size ()
"Return the file size of a file at point (for sorting). Takes
into account git-annex files."
(let* ((filename (dired-get-filename nil t))
(string-file (file-name-nondirectory filename)))
(or (jmm/git-annex-file-size filename)
(file-attribute-size (file-attributes filename)))))
(defun jmm/dired-sort-size (&optional ascending)
"Sort some dired lines by size (consider annex sizes).
With optional argument ASCENDING, sort by ascending file size. (I
like going the other way around usually.)"
(interactive "P")
(if (string= "Git" (vc-responsible-backend default-directory))
(let (buffer-read-only
(beg (jmm/dired-dir-files-beginning))
(end (jmm/dired-dir-files-end)))
(save-excursion
(save-restriction
(narrow-to-region beg end)
(goto-char (point-min))
(sort-subr (not ascending)
'forward-line 'end-of-line
#'jmm/dired-file-size nil))))
(progn
(setq dired-listing-switches (concat dired-default-listing-switches " -t"))
(dired-sort-other dired-listing-switches)))))