diff options
Diffstat (limited to '.config/emacs/lisp/dired-hacks')
| -rw-r--r-- | .config/emacs/lisp/dired-hacks/dired-hacks-utils.el | 275 | ||||
| -rw-r--r-- | .config/emacs/lisp/dired-hacks/dired-subtree.el | 785 |
2 files changed, 1060 insertions, 0 deletions
diff --git a/.config/emacs/lisp/dired-hacks/dired-hacks-utils.el b/.config/emacs/lisp/dired-hacks/dired-hacks-utils.el new file mode 100644 index 0000000..b492f76 --- /dev/null +++ b/.config/emacs/lisp/dired-hacks/dired-hacks-utils.el @@ -0,0 +1,275 @@ +;;; dired-hacks-utils.el --- Utilities and helpers for dired-hacks collection + +;; 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: 14th February 2014 +;; Package-Requires: ((dash "2.5.0") (emacs "24.3")) +;; URL: https://github.com/Fuco1/dired-hacks + +;; 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: + +;; Utilities and helpers for `dired-hacks' collection of dired +;; improvements. + +;; This package also provides these interactive functions: +;; * `dired-hacks-next-file' - go to next file, skipping empty and non-file lines +;; * `dired-hacks-previous-file' - go to previous file, skipping empty +;; and non-file lines +;; * `dired-utils-format-information-line-mode' - Format the information +;; (summary) line file sizes to be human readable (e.g. 1GB instead of 1048576). + + +;; See https://github.com/Fuco1/dired-hacks for the entire collection + +;;; Code: + +(require 'dash) +(require 'dired) +(require 'dired-aux) ;; for dired-dwim-target-directory + +(defgroup dired-hacks () + "Collection of useful dired additions." + :group 'dired + :prefix "dired-hacks-") + +(defcustom dired-hacks-file-size-formatter #'file-size-human-readable + "The function used to format file sizes. + +See `dired-utils-format-file-sizes'." + :type 'function + :group 'dired-hacks) + +(defcustom dired-hacks-datetime-regexp + "\\sw\\sw\\sw....\\(?:[0-9][0-9]:[0-9][0-9]\\|.[0-9]\\{4\\}\\)" + "A regexp matching the date/time in the dired listing. + +It is used to determine where the filename starts. It should +*not* match any characters after the last character of the +timestamp. It is assumed that the timestamp is preceded and +followed by at least one space character. You should only use +shy groups (prefixed with ?:) because the first group is used by +the font-lock to determine what portion of the name should be +colored." + :type 'regexp + :group 'dired-hacks) + +(defalias 'dired-utils--string-trim + (if (and (require 'subr-x nil t) + (fboundp 'string-trim)) + #'string-trim + (lambda (string) + (let ((s string)) + (when (string-match "\\`[ \t\n\r]+" s) + (setq s (replace-match "" t t s))) + (when (string-match "[ \t\n\r]+\\'" s) + (setq s (replace-match "" t t s))) + s))) + "Trim STRING of trailing whitespace. + +\(fn STRING)") + +(defun dired-utils-get-filename (&optional localp) + "Like `dired-get-filename' but never signal an error. + +Optional arg LOCALP with value `no-dir' means don't include +directory name in result." + (dired-get-filename localp t)) + +(defun dired-utils-get-all-files (&optional localp) + "Return all files in this dired buffer as a list. + +LOCALP has same semantics as in `dired-get-filename'." + (save-excursion + (goto-char (point-min)) + (let (r) + (while (= 0 (forward-line)) + (--when-let (dired-utils-get-filename localp) + (push it r))) + (nreverse r)))) + +(defconst dired-utils-file-attributes-keywords + '(:isdir :nlinks :uid :gid :atime :mtime :ctime :size :modes :gidchg :inode :devnum) + "List of keywords to map with `file-attributes'.") + +(defconst dired-utils-info-keywords + `(:name :issym :target ,@dired-utils-file-attributes-keywords) + "List of keywords available for `dired-utils-get-info'.") + +(defun dired-utils--get-keyword-info (keyword) + "Get file information about KEYWORD." + (let ((filename (dired-utils-get-filename))) + (cl-case keyword + (:name filename) + (:isdir (file-directory-p filename)) + (:issym (and (file-symlink-p filename) t)) + (:target (file-symlink-p filename)) + (t + (nth (-elem-index keyword dired-utils-file-attributes-keywords) + (file-attributes filename)))))) + +(defun dired-utils-get-info (&rest keywords) + "Query for info about the file at point. + +KEYWORDS is a list of attributes to query. + +When querying for one attribute, its value is returned. When +querying for more than one, a list of results is returned. + +The available keywords are listed in +`dired-utils-info-keywords'." + (let ((attributes (mapcar 'dired-utils--get-keyword-info keywords))) + (if (> (length attributes) 1) + attributes + (car attributes)))) + +(defun dired-utils-goto-line (filename) + "Go to line describing FILENAME in listing. + +Should be absolute file name matched against +`dired-get-filename'." + (goto-char (point-min)) + (let (stop) + (while (and (not stop) + (= (forward-line) 0)) + (when (equal filename (dired-utils-get-filename)) + (setq stop t) + (dired-move-to-filename))) + stop)) + +(defun dired-utils-match-filename-regexp (filename alist) + "Match FILENAME against each car in ALIST and return first matched cons. + +Each car in ALIST is a regular expression. + +The matching is done using `string-match-p'." + (let (match) + (--each-while alist (not match) + (when (string-match-p (car it) filename) + (setq match it))) + match)) + +(defun dired-utils-match-filename-extension (filename alist) + "Match FILENAME against each car in ALIST and return first matched cons. + +Each car in ALIST is a string representing file extension +*without* the delimiting dot." + (let (done) + (--each-while alist (not done) + (when (string-match-p (concat "\\." (regexp-quote (car it)) "\\'") filename) + (setq done it))) + done)) + +(defun dired-utils-format-information-line () + "Format the disk space on the Dired information line." + (save-excursion + (goto-char (point-min)) + (forward-line) + (let ((inhibit-read-only t) + (limit (line-end-position))) + (while (re-search-forward "\\(?:directory\\|available\\) \\(\\<[0-9]+$\\>\\)" nil t) + (replace-match + (save-match-data + (propertize (dired-utils--string-trim + (funcall dired-hacks-file-size-formatter + (* 1024 (string-to-number (match-string 1))) t)) + 'invisible 'dired-hide-details-information)) + t nil nil 1))))) + + +;;; Predicates +(defun dired-utils-is-file-p () + "Return non-nil if the line at point is a file or a directory." + (dired-utils-get-filename 'no-dir)) + +(defun dired-utils-is-dir-p () + "Return non-nil if the line at point is a directory." + (--when-let (dired-utils-get-filename) + (file-directory-p it))) + + +;;; Interactive +;; TODO: add wrap-around option +(defun dired-hacks-next-file (&optional arg) + "Move point to the next file. + +Optional prefix ARG says how many lines to move; default is one +line." + (interactive "p") + (unless arg (setq arg 1)) + (if (< arg 0) + (dired-hacks-previous-file (- arg)) + (--dotimes arg + (forward-line) + (while (and (or (not (dired-utils-is-file-p)) + (get-text-property (point) 'invisible)) + (= (forward-line) 0)))) + (if (not (= (point) (point-max))) + (dired-move-to-filename) + (forward-line -1) + (dired-move-to-filename) + nil))) + +(defun dired-hacks-previous-file (&optional arg) + "Move point to the previous file. + +Optional prefix ARG says how many lines to move; default is one +line." + (interactive "p") + (unless arg (setq arg 1)) + (if (< arg 0) + (dired-hacks-next-file (- arg)) + (--dotimes arg + (forward-line -1) + (while (and (or (not (dired-utils-is-file-p)) + (get-text-property (point) 'invisible)) + (= (forward-line -1) 0)))) + (if (not (= (point) (point-min))) + (dired-move-to-filename) + (dired-hacks-next-file) + nil))) + +(defun dired-hacks-compare-files (file-a file-b) + "Test if two files FILE-A and FILE-B are the (probably) the same." + (interactive (let ((other-dir (dired-dwim-target-directory))) + (list (read-file-name "File A: " default-directory (car (dired-get-marked-files)) t) + (read-file-name "File B: " other-dir (with-current-buffer (cdr (assoc other-dir dired-buffers)) + (car (dired-get-marked-files))) t)))) + (let ((md5-a (with-temp-buffer + (shell-command (format "md5sum %s" file-a) (current-buffer)) + (buffer-string))) + (md5-b (with-temp-buffer + (shell-command (format "md5sum %s" file-b) (current-buffer)) + (buffer-string)))) + (message "%s%sFiles are %s." md5-a md5-b + (if (equal (car (split-string md5-a)) + (car (split-string md5-b))) + "probably the same" "different")))) + +(define-minor-mode dired-utils-format-information-line-mode + "Toggle formatting of disk space in the Dired information line." + :group 'dired-utils + :lighter "" + (if dired-utils-format-information-line-mode + (add-hook 'dired-after-readin-hook #'dired-utils-format-information-line) + (remove-hook 'dired-after-readin-hook #'dired-utils-format-information-line))) + +(provide 'dired-hacks-utils) + +;;; dired-hacks-utils.el ends here diff --git a/.config/emacs/lisp/dired-hacks/dired-subtree.el b/.config/emacs/lisp/dired-hacks/dired-subtree.el new file mode 100644 index 0000000..d50ab96 --- /dev/null +++ b/.config/emacs/lisp/dired-hacks/dired-subtree.el @@ -0,0 +1,785 @@ +;;; 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") (emacs "24.3")) +;; URL: https://github.com/Fuco1/dired-hacks + +;; 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))) + (insert "\n") + (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 |
