ld/ld-emacs
1
0
Fork 0
mirror of https://github.com/lliding/ld-emacs.git synced 2025-10-13 05:23:05 +00:00
Code Issues Packages Projects Releases Wiki Activity
ld-emacs/site-lisp/extensions-local/dired-subtree.el
liding 92c3e19a46 First release.
2023-12-23 16:24:30 +08:00

785 lines
27 KiB
EmacsLisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; dired-subtree.el --- Insert subdirectories in a tree-like fashion
;; Copyright (C) 2014-2015 Matúš Goljer
;; Author: Matúš Goljer <matus.goljer@gmail.com>
;; Maintainer: Matúš Goljer <matus.goljer@gmail.com>
;; Keywords: files
;; Version: 0.0.1
;; Created: 25th February 2014
;; Package-Requires: ((dash "2.5.0") (dired-hacks-utils "0.0.1"))
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Introduction
;; ------------
;; The basic command to work with subdirectories in dired is `i',
;; which inserts the subdirectory as a separate listing in the active
;; dired buffer.
;; This package defines function `dired-subtree-insert' which instead
;; inserts the subdirectory directly below its line in the original
;; listing, and indent the listing of subdirectory to resemble a
;; tree-like structure (somewhat similar to tree(1) except the pretty
;; graphics). The tree display is somewhat more intuitive than the
;; default "flat" subdirectory manipulation provided by `i'.
;; There are several presentation options and faces you can customize
;; to change the way subtrees are displayed.
;; You can further remove the unwanted lines from the subtree by using
;; `k' command or some of the built-in "focusing" functions, such as
;; `dired-subtree-only-*' (see list below).
;; If you have the package `dired-filter', you can additionally filter
;; the subtrees with global or local filters.
;; A demo of basic functionality is available on youtube:
;; https://www.youtube.com/watch?v=z26b8HKFsNE
;; Interactive functions
;; ---------------------
;; Here's a list of available interactive functions. You can read
;; more about each one by using the built-in documentation facilities
;; of emacs. It is adviced to place bindings for these into a
;; convenient prefix key map, for example C-,
;; * `dired-subtree-insert'
;; * `dired-subtree-remove'
;; * `dired-subtree-toggle'
;; * `dired-subtree-cycle'
;; * `dired-subtree-revert'
;; * `dired-subtree-narrow'
;; * `dired-subtree-up'
;; * `dired-subtree-down'
;; * `dired-subtree-next-sibling'
;; * `dired-subtree-previous-sibling'
;; * `dired-subtree-beginning'
;; * `dired-subtree-end'
;; * `dired-subtree-mark-subtree'
;; * `dired-subtree-unmark-subtree'
;; * `dired-subtree-only-this-file'
;; * `dired-subtree-only-this-directory'
;; If you have package `dired-filter', additional command
;; `dired-subtree-apply-filter' is available.
;; See https://github.com/Fuco1/dired-hacks for the entire collection.
;;; Code:
(require 'dired-hacks-utils)
(require 'dash)
(require 'cl-lib)
(defgroup dired-subtree ()
"Insert subdirectories in a tree-like fashion."
:group 'dired-hacks
:prefix "dired-subtree-")
(defcustom dired-subtree-line-prefix " "
"A prefix put into each nested subtree.
The prefix is repeated \"depth\" times.
Alternatively, it can be a function taking one argument---the
depth---that creates the prefix."
:type '(choice string function)
:group 'dired-subtree)
(defcustom dired-subtree-line-prefix-face 'parents
"Specifies how the prefix is fontified."
:type '(radio
(const :tag "No face applied" nil)
(const :tag "Inherit from current subtree" subtree)
(const :tag "Inherit from all parents" parents))
:group 'dired-subtree)
(defcustom dired-subtree-use-backgrounds t
"When non-nil, add a background face to a subtree listing."
:type 'boolean
:group 'dired-subtree)
(defcustom dired-subtree-after-insert-hook ()
"Hook run at the end of `dired-subtree-insert'."
:type 'hook
:group 'dired-subtree)
(defcustom dired-subtree-after-remove-hook ()
"Hook run at the end of `dired-subtree-remove'."
:type 'hook
:group 'dired-subtree)
(defcustom dired-subtree-cycle-depth 3
"Default depth expanded by `dired-subtree-cycle'."
:type 'natnum
:group 'dired-subtree)
(defcustom dired-subtree-ignored-regexp
(concat "^" (regexp-opt vc-directory-exclusion-list) "$")
"Matching directories will not be expanded in `dired-subtree-cycle'."
:type 'regexp
:group 'dired-subtree)
(defgroup dired-subtree-faces ()
"Faces used in `dired-subtree'."
:group 'dired-subtree)
(defface dired-subtree-depth-1-face
'((t (:background "#252e30")))
"Background for depth 1 subtrees"
:group 'dired-subtree-faces)
(defface dired-subtree-depth-2-face
'((t (:background "#232a2b")))
"Background for depth 2 subtrees"
:group 'dired-subtree-faces)
(defface dired-subtree-depth-3-face
'((t (:background "#212627")))
"Background for depth 3 subtrees"
:group 'dired-subtree-faces)
(defface dired-subtree-depth-4-face
'((t (:background "#1e2223")))
"Background for depth 4 subtrees"
:group 'dired-subtree-faces)
(defface dired-subtree-depth-5-face
'((t (:background "#1c1d1e")))
"Background for depth 5 subtrees"
:group 'dired-subtree-faces)
(defface dired-subtree-depth-6-face
'((t (:background "#1a191a")))
"Background for depth 6 subtrees"
:group 'dired-subtree-faces)
(defvar dired-subtree-overlays nil
"Subtree overlays in this buffer.")
(make-variable-buffer-local 'dired-subtree-overlays)
;;; Overlay manipulation
;; Maybe we should abstract the overlay-foo into some subtree
;; functions instead!!!
(defun dired-subtree--remove-overlay (ov)
"Remove dired-subtree overlay OV."
(setq dired-subtree-overlays
(--remove (equal it ov) dired-subtree-overlays))
(delete-overlay ov))
(defun dired-subtree--remove-overlays (ovs)
"Remove dired-subtree overlays OVS."
(mapc 'dired-subtree--remove-overlay ovs))
(defun dired-subtree--cleanup-overlays ()
"Remove the `nil' values from `dired-subtree-overlays'."
(setq dired-subtree-overlays
(--remove (not (overlay-buffer it)) dired-subtree-overlays)))
(defun dired-subtree--get-all-ovs ()
"Get all dired-subtree overlays in this buffer."
(--filter (overlay-get it 'dired-subtree-depth) (overlays-in (point-min) (point-max))))
(defun dired-subtree--get-all-ovs-at-point (&optional p)
"Get all dired-subtree overlays at point P."
(setq p (or p (point)))
(--filter (overlay-get it 'dired-subtree-depth) (overlays-at (point))))
(defun dired-subtree--get-ovs-in (&optional beg end)
"Get all dired-subtree overlays between BEG and END.
BEG and END default to the region spanned by overlay at point."
(when (not beg)
(let ((ov (dired-subtree--get-ov)))
(setq beg (overlay-start ov))
(setq end (overlay-end ov))))
(--filter (and (overlay-get it 'dired-subtree-depth)
(>= (overlay-start it) beg)
(<= (overlay-end it) end))
(overlays-in (point-min) (point-max))))
(defun dired-subtree--get-ov (&optional p)
"Get the parent subtree overlay at point."
(setq p (or p (point)))
(car (--sort (> (overlay-get it 'dired-subtree-depth)
(overlay-get other 'dired-subtree-depth))
(dired-subtree--get-all-ovs-at-point p))))
(defun dired-subtree--get-depth (ov)
"Get subtree depth."
(or (and ov (overlay-get ov 'dired-subtree-depth)) 0))
;;; helpers
(defvar dired-subtree-preserve-properties '(dired-subtree-filter)
"Properties that should be preserved between read-ins.")
(defun dired-subtree--after-readin (&optional subtrees)
"Insert the SUBTREES again after dired buffer has been reverted.
If no SUBTREES are specified, use `dired-subtree-overlays'."
(-when-let (subtrees-to-process (or subtrees dired-subtree-overlays))
(let* ((ovs-by-depth (--sort (< (car it) (car other))
(--group-by (overlay-get it 'dired-subtree-depth)
subtrees-to-process)))
(sorted-ovs (--map (cons (car it)
(--map (-cons* it
(overlay-get it 'dired-subtree-name)
(-map (lambda (x) (cons x (overlay-get it x)))
dired-subtree-preserve-properties)) (cdr it)))
ovs-by-depth)))
;; (depth (path1 ov1 (prop1 . value1) (prop2 . value2)) (path2 ...))
(--each sorted-ovs
(--each (cdr it)
(when (dired-utils-goto-line (cadr it))
(dired-subtree--remove-overlay (car it))
(dired-subtree-insert)
(let ((ov (dired-subtree--get-ov)))
(--each (cddr it)
(overlay-put ov (car it) (cdr it)))
(dired-subtree--filter-subtree ov))))))))
(defun dired-subtree--after-insert ()
"After inserting the subtree, setup dired-details/dired-hide-details-mode."
(if (fboundp 'dired-insert-set-properties)
(let ((inhibit-read-only t)
(ov (dired-subtree--get-ov)))
(dired-insert-set-properties (overlay-start ov) (overlay-end ov)))
(when (featurep 'dired-details)
(dired-details-delete-overlays)
(dired-details-activate))))
(add-hook 'dired-after-readin-hook 'dired-subtree--after-readin)
(add-hook 'dired-subtree-after-insert-hook 'dired-subtree--after-insert)
(defun dired-subtree--unmark ()
"Unmark a file without moving point."
(save-excursion (dired-unmark 1)))
(defun dired-subtree--dired-line-is-directory-or-link-p ()
"Return non-nil if line under point is a directory or symlink"
;; We've replaced `file-directory-p' with the regexp test to
;; speed up filters over TRAMP. So long as dired/ls format
;; doesn't change, we're good.
;; 'd' for directories, 'l' for potential symlinks to directories.
(save-excursion (beginning-of-line) (looking-at "..[dl]")))
(defun dired-subtree--is-expanded-p ()
"Return non-nil if directory under point is expanded."
(save-excursion
(when (dired-utils-get-filename)
(let ((depth (dired-subtree--get-depth (dired-subtree--get-ov))))
(dired-next-line 1)
(< depth (dired-subtree--get-depth (dired-subtree--get-ov)))))))
(defmacro dired-subtree-with-subtree (&rest forms)
"Run FORMS on each file in this subtree."
(declare (debug (body)))
`(save-excursion
(dired-subtree-beginning)
,@forms
(while (dired-subtree-next-sibling)
,@forms)))
;;;; Interactive
;;;###autoload
(defun dired-subtree-narrow ()
"Narrow the buffer to this subtree."
(interactive)
(-when-let (ov (dired-subtree--get-ov))
(narrow-to-region (overlay-start ov)
(overlay-end ov))))
;;; Navigation
;; make the arguments actually do something
;;;###autoload
(defun dired-subtree-up (&optional arg)
"Jump up one directory."
(interactive "p")
(-when-let (ov (dired-subtree--get-ov))
(goto-char (overlay-start ov))
(dired-previous-line 1)))
;;;###autoload
(defun dired-subtree-down (&optional arg)
"Jump down one directory."
(interactive "p")
(-when-let* ((p (point))
(ov (car (--sort
(< (overlay-start it)
(overlay-start other))
(--remove
(< (overlay-start it) p)
(dired-subtree--get-all-ovs))))))
(goto-char (overlay-start ov))
(dired-move-to-filename)))
;;;###autoload
(defun dired-subtree-next-sibling (&optional arg)
"Go to the next sibling."
(interactive "p")
(let ((current-ov (dired-subtree--get-ov)))
(dired-next-line 1)
(let ((new-ov (dired-subtree--get-ov)))
(cond
((not (dired-utils-is-file-p))
nil)
((< (dired-subtree--get-depth current-ov)
(dired-subtree--get-depth new-ov))
(goto-char (overlay-end new-ov))
(dired-move-to-filename)
t)
((> (dired-subtree--get-depth current-ov)
(dired-subtree--get-depth new-ov))
;; add option to either go to top or stay at the end
(dired-previous-line 1)
nil)
(t t)))))
;;;###autoload
(defun dired-subtree-previous-sibling (&optional arg)
"Go to the previous sibling."
(interactive "p")
(let ((current-ov (dired-subtree--get-ov)))
(dired-previous-line 1)
(let ((new-ov (dired-subtree--get-ov)))
(cond
;; this will need better handlign if we have inserted
;; subdirectories
((not (dired-utils-is-file-p))
nil)
((< (dired-subtree--get-depth current-ov)
(dired-subtree--get-depth new-ov))
(goto-char (overlay-start new-ov))
(dired-previous-line 1)
t)
((> (dired-subtree--get-depth current-ov)
(dired-subtree--get-depth new-ov))
;; add option to either go to top or stay at the end
(dired-next-line 1)
nil)
(t t)))))
;;;###autoload
(defun dired-subtree-beginning ()
"Go to the first file in this subtree."
(interactive)
(let ((ov (dired-subtree--get-ov)))
(if (not ov)
;; do something when not in subtree
t
(goto-char (overlay-start ov))
(dired-move-to-filename))))
;;;###autoload
(defun dired-subtree-end ()
"Go to the first file in this subtree."
(interactive)
(let ((ov (dired-subtree--get-ov)))
(if (not ov)
;; do something when not in subtree
t
(goto-char (overlay-end ov))
(dired-previous-line 1))))
;;; Marking
;;;###autoload
(defun dired-subtree-mark-subtree (&optional all)
"Mark all files in this subtree.
With prefix argument mark all the files in subdirectories
recursively."
(interactive "P")
(save-excursion
(if all
(let ((beg (save-excursion
(dired-subtree-beginning)
(point)))
(end (save-excursion
(dired-subtree-end)
(point))))
(dired-mark-files-in-region
(progn (goto-char beg) (line-beginning-position))
(progn (goto-char end) (line-end-position))))
(dired-subtree-beginning)
(save-excursion (dired-mark 1))
(while (dired-subtree-next-sibling)
(save-excursion (dired-mark 1))))))
;;;###autoload
(defun dired-subtree-unmark-subtree (&optional all)
"Unmark all files in this subtree.
With prefix argument unmark all the files in subdirectories
recursively."
(interactive)
(let ((dired-marker-char ? ))
(dired-subtree-mark-subtree all)))
;;; Insertion/deletion
;;;###autoload
(defun dired-subtree-revert ()
"Revert the subtree.
This means reinserting the content of this subtree and all its
children."
(interactive)
(let ((inhibit-read-only t)
(file-name (dired-utils-get-filename)))
(-when-let* ((ov (dired-subtree--get-ov))
(ovs (dired-subtree--get-ovs-in)))
(dired-subtree-up)
(delete-region (overlay-start ov) (overlay-end ov))
(dired-subtree--after-readin ovs)
(when file-name
(dired-utils-goto-line file-name)))))
(defun dired-subtree--readin (dir-name)
"Read in the directory.
Return a string suitable for insertion in `dired' buffer."
(with-temp-buffer
(insert-directory dir-name dired-listing-switches nil t)
(delete-char -1)
(goto-char (point-min))
(delete-region
(progn (beginning-of-line) (point))
(progn (forward-line
(if (save-excursion
(forward-line 1)
(end-of-line)
(looking-back "\\."))
3 1)) (point)))
(insert " ")
(while (= (forward-line) 0)
(insert " "))
(delete-char -2)
(buffer-string)))
;;;###autoload
(defun dired-subtree-insert ()
"Insert subtree under this directory."
(interactive)
(when (and (dired-subtree--dired-line-is-directory-or-link-p)
(not (dired-subtree--is-expanded-p)))
(let* ((dir-name (dired-get-filename nil))
(listing (dired-subtree--readin (file-name-as-directory dir-name)))
beg end)
(read-only-mode -1)
(move-end-of-line 1)
;; this is pretty ugly, I'm sure it can be done better
(save-excursion
(insert listing)
(setq end (+ (point) 2)))
(newline)
(setq beg (point))
(let ((inhibit-read-only t))
(remove-text-properties (1- beg) beg '(dired-filename)))
(let* ((ov (make-overlay beg end))
(parent (dired-subtree--get-ov (1- beg)))
(depth (or (and parent (1+ (overlay-get parent 'dired-subtree-depth)))
1))
(face (intern (format "dired-subtree-depth-%d-face" depth))))
(when dired-subtree-use-backgrounds
(overlay-put ov 'face face))
;; refactor this to some function
(overlay-put ov 'line-prefix
(if (stringp dired-subtree-line-prefix)
(if (not dired-subtree-use-backgrounds)
(apply 'concat (-repeat depth dired-subtree-line-prefix))
(cond
((eq nil dired-subtree-line-prefix-face)
(apply 'concat
(-repeat depth dired-subtree-line-prefix)))
((eq 'subtree dired-subtree-line-prefix-face)
(concat
dired-subtree-line-prefix
(propertize
(apply 'concat
(-repeat (1- depth) dired-subtree-line-prefix))
'face face)))
((eq 'parents dired-subtree-line-prefix-face)
(concat
dired-subtree-line-prefix
(apply 'concat
(--map
(propertize dired-subtree-line-prefix
'face
(intern (format "dired-subtree-depth-%d-face" it)))
(number-sequence 1 (1- depth))))))))
(funcall dired-subtree-line-prefix depth)))
(overlay-put ov 'dired-subtree-name dir-name)
(overlay-put ov 'dired-subtree-parent parent)
(overlay-put ov 'dired-subtree-depth depth)
(overlay-put ov 'evaporate t)
(push ov dired-subtree-overlays))
(goto-char beg)
(dired-move-to-filename)
(read-only-mode 1)
(when (bound-and-true-p dired-filter-mode) (dired-filter-mode 1))
(run-hooks 'dired-subtree-after-insert-hook))))
;;;###autoload
(defun dired-subtree-remove ()
"Remove subtree at point."
(interactive)
(-when-let* ((ov (dired-subtree--get-ov))
(ovs (dired-subtree--get-ovs-in
(overlay-start ov)
(overlay-end ov))))
(let ((inhibit-read-only t))
(dired-subtree-up)
(delete-region (overlay-start ov)
(overlay-end ov))
(dired-subtree--remove-overlays ovs)))
(run-hooks 'dired-subtree-after-remove-hook))
;;;###autoload
(defun dired-subtree-toggle ()
"Insert subtree at point or remove it if it was not present."
(interactive)
(if (dired-subtree--is-expanded-p)
(progn
(dired-next-line 1)
(dired-subtree-remove)
;; #175 fixes the case of the first line in dired when the
;; cursor jumps to the header in dired rather then to the
;; first file in buffer
(when (bobp)
(dired-next-line 1)))
(save-excursion (dired-subtree-insert))))
(defun dired-subtree--insert-recursive (depth max-depth)
"Insert full subtree at point."
(save-excursion
(let ((name (dired-get-filename nil t)))
(when (and name (file-directory-p name)
(<= depth (or max-depth depth))
(or (= 1 depth)
(not (string-match-p dired-subtree-ignored-regexp
(file-name-nondirectory name)))))
(if (dired-subtree--is-expanded-p)
(dired-next-line 1)
(dired-subtree-insert))
(dired-subtree-end)
(dired-subtree--insert-recursive (1+ depth) max-depth)
(while (dired-subtree-previous-sibling)
(dired-subtree--insert-recursive (1+ depth) max-depth))))))
(defvar dired-subtree--cycle-previous nil
"Remember previous action for `dired-subtree-cycle'")
;;;###autoload
(defun dired-subtree-cycle (&optional max-depth)
"Org-mode like cycle visibility:
1) Show subtree
2) Show subtree recursively (if previous command was cycle)
3) Remove subtree
Numeric prefix will set max depth"
(interactive "P")
(save-excursion
(cond
;; prefix - show subtrees up to max-depth
(max-depth
(when (dired-subtree--is-expanded-p)
(dired-next-line 1)
(dired-subtree-remove))
(dired-subtree--insert-recursive 1 (if (integerp max-depth) max-depth nil))
(setq dired-subtree--cycle-previous :full))
;; if directory is not expanded, expand one level
((not (dired-subtree--is-expanded-p))
(dired-subtree-insert)
(setq dired-subtree--cycle-previous :insert))
;; hide if previous command was not cycle or tree was fully expanded
((or (not (eq last-command 'dired-subtree-cycle))
(eq dired-subtree--cycle-previous :full))
(dired-next-line 1)
(dired-subtree-remove)
(setq dired-subtree--cycle-previous :remove))
(t
(dired-subtree--insert-recursive 1 dired-subtree-cycle-depth)
(setq dired-subtree--cycle-previous :full)))))
(defun dired-subtree--filter-up (keep-dir kill-siblings)
(save-excursion
(let (ov)
(save-excursion
(while (dired-subtree-up))
(dired-next-line 1)
(dired-subtree-mark-subtree t))
(if keep-dir
(dired-subtree-unmark-subtree)
(dired-subtree--unmark))
(while (and (dired-subtree-up)
(> (dired-subtree--get-depth (dired-subtree--get-ov)) 0))
(if (not kill-siblings)
(dired-subtree--unmark)
(dired-subtree--unmark)
(let ((here (point)))
(dired-subtree-with-subtree
(when (and (dired-subtree--is-expanded-p)
(/= (point) here))
(dired-subtree--unmark)
(save-excursion
(dired-next-line 1)
(dired-subtree-unmark-subtree t)))))))
(dired-do-kill-lines)
(dired-subtree--cleanup-overlays))))
;;;###autoload
(defun dired-subtree-only-this-file (&optional arg)
"Remove all the siblings on the route from this file to the top-most directory.
With ARG non-nil, do not remove expanded directories in parents."
(interactive "P")
(dired-subtree--filter-up nil arg))
;;;###autoload
(defun dired-subtree-only-this-directory (&optional arg)
"Remove all the siblings on the route from this directory to the top-most directory.
With ARG non-nil, do not remove expanded directories in parents."
(interactive "P")
(dired-subtree--filter-up t arg))
;;; filtering
(defun dired-subtree--filter-update-bs (ov)
"Update the local filter list.
This function assumes that `dired-filter-stack' is dynamically
bound to relevant value."
(let* ((filt (dired-filter--describe-filters))
(before-str (if (equal filt "") nil (concat " Local filters: " filt "\n"))))
(overlay-put ov 'before-string before-str)))
(defun dired-subtree--filter-subtree (ov)
"Run the filter for this subtree.
It is only safe to call this from readin.
This depends on `dired-filter' package."
(when (featurep 'dired-filter)
(let ((dired-filter-stack (overlay-get ov 'dired-subtree-filter)))
(save-restriction
(widen)
(dired-subtree-narrow)
(dired-filter--expunge)
(dired-subtree--filter-update-bs ov)))))
;;;###autoload
(defun dired-subtree-apply-filter ()
"Push a local filter for this subtree.
This depends on `dired-filter' package.
It works exactly the same as global dired filters, only
restricted to a subtree. The global filter is also applied to
the subtree. The filter action is read from `dired-filter-map'."
(interactive)
(when (featurep 'dired-filter)
(-when-let (ov (dired-subtree--get-ov))
(let ((dired-filter-stack (overlay-get ov 'dired-subtree-filter))
(glob (current-global-map))
(loc (current-local-map))
cmd)
(cl-flet ((dired-filter--update
()
(save-restriction
(overlay-put ov 'dired-subtree-filter dired-filter-stack)
(widen)
(dired-subtree-revert)
(dired-subtree--filter-update-bs ov))))
(unwind-protect
(progn
(use-global-map dired-filter-map)
(use-local-map nil)
(setq cmd (key-binding (read-key-sequence "Choose filter action: "))))
(use-global-map glob)
(use-local-map loc))
(let ((p (point))
(beg (overlay-start ov))
(current-file (dired-utils-get-filename)))
(unwind-protect
(call-interactively cmd)
(unless (dired-utils-goto-line current-file)
(goto-char beg)
(forward-line)
(goto-char (min p (1- (overlay-end (dired-subtree--get-ov)))))
(dired-move-to-filename)))))))))
;;; Here we redefine a couple of functions from dired.el to make them
;;; subtree-aware
;; If the point is in a subtree, we need to provide a proper
;; directory, not the one that would come from `dired-subdir-alist'.
(defun dired-current-directory (&optional localp)
"Return the name of the subdirectory to which this line belongs.
This returns a string with trailing slash, like `default-directory'.
Optional argument means return a file name relative to `default-directory'."
(let ((here (point))
(alist (or dired-subdir-alist
;; probably because called in a non-dired buffer
(error "No subdir-alist in %s" (current-buffer))))
elt dir)
(while alist
(setq elt (car alist)
dir (car elt)
;; use `<=' (not `<') as subdir line is part of subdir
alist (if (<= (dired-get-subdir-min elt) here)
nil ; found
(cdr alist))))
;; dired-subdir: modify dir here if we are in a "subtree" view
(-when-let (parent (dired-subtree--get-ov))
(setq dir (concat (overlay-get parent 'dired-subtree-name) "/")))
;; end
(if localp
(dired-make-relative dir default-directory)
dir)))
;; Since the tree-inserted directory is not in the dired-subdir-alist,
;; we need to guard against nil.
(defun dired-get-subdir ()
;;"Return the subdir name on this line, or nil if not on a headerline."
;; Look up in the alist whether this is a headerline.
(save-excursion
(let ((cur-dir (dired-current-directory)))
(beginning-of-line) ; alist stores b-o-l positions
(and (zerop (- (point)
(or (dired-get-subdir-min
(assoc cur-dir
dired-subdir-alist))
0))) ;; dired-subtree: return zero if current
;; dir is not in `dired-subdir-alist'.
cur-dir))))
(provide 'dired-subtree)
;;; dired-subtree.el ends here
Reference in New Issue View Git Blame Copy Permalink