From cdae3738782a356dda632d1b78d5f5b45bdc89a0 Mon Sep 17 00:00:00 2001 From: William Xu Date: Sun, 24 Oct 2021 13:03:54 +0200 Subject: [PATCH] Make Dired path segments jumpable by mouse click (bug#21973) * lisp/dired.el (dired-readin): Call dired-make-path-jumpable. (dired-make-path-jumpable, dired-jump-to-path-segment): New functions. --- lisp/dired.el | 42 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 41 insertions(+), 1 deletion(-) diff --git a/lisp/dired.el b/lisp/dired.el index 4652589122..216c082e7b 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -272,7 +272,7 @@ dired-before-readin-hook :group 'dired :type 'hook) -(defcustom dired-after-readin-hook nil +(defcustom dired-after-readin-hook '(dired-make-path-jumpable) "Hook run after each time a file or directory is read by Dired. After each listing of a file or directory, this hook is run with the buffer narrowed to the listing." @@ -1643,6 +1643,46 @@ dired-insert-set-properties 'invisible 'dired-hide-details-link)))) (forward-line 1)))) +(defun dired-make-path-jumpable () + "Make dired path line at top jumpable." + (let ((inhibit-read-only t)) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^ /" nil t 1) + (let ((bound (line-end-position)) + (segment-start (point)) + segment-end) + (while (search-forward "/" bound t 1) + (setq segment-end (1- (point))) + (add-text-properties segment-start segment-end + `(mouse-face + highlight + help-echo "mouse-1: goto here" + keymap ,(let ((map (make-sparse-keymap))) + (define-key map [down-mouse-1] 'dired-jump-to-path-segment) + map))) + (setq segment-start (point)))))))) + +(defun dired-jump-to-path-segment (event) + "Jump to the directory from a segment of the dired path." + (interactive "e") + (let* ((ev (event-end event)) + (window (posn-window ev)) + (pos (posn-point ev))) + (with-current-buffer (window-buffer window) + (let (beg end) + (save-excursion + (goto-char pos) + (when (search-forward "/" (line-end-position) t 1) + (setq end (point)) + (while (search-backward "/" (line-beginning-position) t 1) + (setq beg (point))))) + (when beg + (let ((dir (buffer-substring-no-properties beg end))) + (if (member dir (mapcar 'car dired-subdir-alist)) + (dired-goto-subdir dir) + (dired dir)))))))) + ;;; Reverting a dired buffer -- 2.25.1