diff options
| -rw-r--r-- | modules/dirvish-config.el | 89 | ||||
| -rw-r--r-- | tests/test-dirvish-config-resolve-display-path.el | 86 |
2 files changed, 129 insertions, 46 deletions
diff --git a/modules/dirvish-config.el b/modules/dirvish-config.el index fa5567ad..c01bfafa 100644 --- a/modules/dirvish-config.el +++ b/modules/dirvish-config.el @@ -405,6 +405,32 @@ Uses feh on X11, swww on Wayland." ;; --------------------------------- Copy Path --------------------------------- +(defun cj/--dired-resolve-display-path (file project-root home-dir + &optional force-absolute) + "Return a (PATH . PATH-TYPE) cons describing how to display FILE. + +PATH-TYPE is one of \"absolute\", \"project-relative\", or \"home-relative\". + +Resolution order: FORCE-ABSOLUTE wins over everything; otherwise an active +PROJECT-ROOT yields a project-relative path; otherwise a file under +HOME-DIR yields a `~/'-prefixed home-relative path (or the bare \"~\" +glyph when FILE is the home dir itself); otherwise the absolute FILE. + +Pure helper used by `cj/dired-copy-path-as-kill'." + (cond + (force-absolute + (cons file "absolute")) + (project-root + (cons (file-relative-name file project-root) "project-relative")) + ((string-prefix-p home-dir file) + (let ((relative-from-home (file-relative-name file home-dir))) + (cons (if (string= relative-from-home ".") + "~" + (concat "~/" relative-from-home)) + "home-relative"))) + (t + (cons file "absolute")))) + (defun cj/dired-copy-path-as-kill (&optional as-org-link force-absolute) "Copy path of file at point in Dired/Dirvish. Copies relative path from project root if in a project, otherwise from home @@ -414,54 +440,25 @@ When FORCE-ABSOLUTE is non-nil, always copy the absolute path." (interactive "P") (unless (derived-mode-p 'dired-mode) (user-error "Not in a Dired buffer")) - - (let* ((file (dired-get-filename nil t)) - (file-name (file-name-nondirectory file)) - (project-root (cj/get-project-root)) - (home-dir (expand-file-name "~")) - path path-type) - + (let ((file (dired-get-filename nil t))) (unless file (user-error "No file at point")) - - (cond - ;; Force absolute path - (force-absolute - (setq path file - path-type "absolute")) - - ;; Project-relative path - (project-root - (setq path (file-relative-name file project-root) - path-type "project-relative")) - - ;; Home-relative path - ((string-prefix-p home-dir file) - (let ((relative-from-home (file-relative-name file home-dir))) - (setq path (if (string= relative-from-home ".") - "~" - (concat "~/" relative-from-home)) - path-type "home-relative"))) - - ;; Absolute path - (t - (setq path file - path-type "absolute"))) - - ;; Format as org-link if requested - (when as-org-link - (setq path (format "[[file:%s][%s]]" path file-name))) - - ;; Copy to kill-ring and clipboard - (kill-new path) - - ;; Provide feedback - (message "Copied %s path%s: %s" - path-type - (if as-org-link " as org-link" "") - (if (> (length path) 60) - (concat (substring path 0 57) "...") - path)))) + (let* ((file-name (file-name-nondirectory file)) + (resolved (cj/--dired-resolve-display-path + file (cj/get-project-root) + (expand-file-name "~") force-absolute)) + (path (car resolved)) + (path-type (cdr resolved)) + (output (if as-org-link + (format "[[file:%s][%s]]" path file-name) + path))) + (kill-new output) + (message "Copied %s path%s: %s" + path-type + (if as-org-link " as org-link" "") + (if (> (length output) 60) + (concat (substring output 0 57) "...") + output))))) (defun cj/get-project-root () "Get project root using projectile or project.el. diff --git a/tests/test-dirvish-config-resolve-display-path.el b/tests/test-dirvish-config-resolve-display-path.el new file mode 100644 index 00000000..dbd36a81 --- /dev/null +++ b/tests/test-dirvish-config-resolve-display-path.el @@ -0,0 +1,86 @@ +;;; test-dirvish-config-resolve-display-path.el --- Tests for the path-resolution helper -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/--dired-resolve-display-path' is the pure logic underneath +;; `cj/dired-copy-path-as-kill'. Given the absolute FILE, the active +;; PROJECT-ROOT (or nil), the user's HOME-DIR, and a FORCE-ABSOLUTE +;; flag, the helper returns a (PATH . PATH-TYPE) cons describing what +;; to copy and how to label it. The interactive wrapper does the +;; clipboard write and the user-visible message. + +;;; Code: + +(require 'ert) +(require 'package) + +(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) +(package-initialize) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "elpa/dirvish-2.3.0/extensions" + user-emacs-directory)) +(require 'user-constants) +(require 'keybindings) +(require 'dirvish-config) + +(ert-deftest test-cj--dired-resolve-display-path-project-relative () + "Normal: file inside a project returns a project-relative path." + (should (equal (cj/--dired-resolve-display-path + "/home/me/code/proj/src/main.el" + "/home/me/code/proj/" + "/home/me") + (cons "src/main.el" "project-relative")))) + +(ert-deftest test-cj--dired-resolve-display-path-home-relative () + "Normal: file under home but not in any project returns a ~/-prefixed path." + (should (equal (cj/--dired-resolve-display-path + "/home/me/notes/today.org" + nil + "/home/me") + (cons "~/notes/today.org" "home-relative")))) + +(ert-deftest test-cj--dired-resolve-display-path-home-itself () + "Boundary: file IS the home dir -> path is the bare ~ glyph." + (should (equal (cj/--dired-resolve-display-path + "/home/me" + nil + "/home/me") + (cons "~" "home-relative")))) + +(ert-deftest test-cj--dired-resolve-display-path-absolute-fallback () + "Boundary: file outside home and no project -> absolute path." + (should (equal (cj/--dired-resolve-display-path + "/etc/hosts" + nil + "/home/me") + (cons "/etc/hosts" "absolute")))) + +(ert-deftest test-cj--dired-resolve-display-path-force-absolute-overrides-project () + "Normal: FORCE-ABSOLUTE wins over an active project root." + (should (equal (cj/--dired-resolve-display-path + "/home/me/code/proj/src/main.el" + "/home/me/code/proj/" + "/home/me" + t) + (cons "/home/me/code/proj/src/main.el" "absolute")))) + +(ert-deftest test-cj--dired-resolve-display-path-force-absolute-overrides-home () + "Normal: FORCE-ABSOLUTE wins over a home-prefix match." + (should (equal (cj/--dired-resolve-display-path + "/home/me/notes/today.org" + nil + "/home/me" + t) + (cons "/home/me/notes/today.org" "absolute")))) + +(ert-deftest test-cj--dired-resolve-display-path-project-precedes-home () + "Normal: when a file is BOTH inside a project and under home, the project +view wins. This matches the original code -- projects are usually under +home and the project-relative form reads more usefully." + (should (equal (cj/--dired-resolve-display-path + "/home/me/code/proj/src/main.el" + "/home/me/code/proj/" + "/home/me") + (cons "src/main.el" "project-relative")))) + +(provide 'test-dirvish-config-resolve-display-path) +;;; test-dirvish-config-resolve-display-path.el ends here |