[nongnu] elpa/sesman 53efa0a9ca 086/100: Honor sesman-follow-symlinks in path expansion and project lookup

[ELPA Syncer]

branch: elpa/sesman
commit 53efa0a9cac112d0410279ebec94206e48e4023f
Author: Vitalie Spinu <spinuvit@gmail.com>
Commit: Vitalie Spinu <spinuvit@gmail.com>

    Honor sesman-follow-symlinks in path expansion and project lookup
    
      Close clojure-emacs/cider#2505
---
 sesman-test.el | 51 +++++++++++++++++++++++++++++++++++++++++
 sesman.el      | 72 ++++++++++++++++++++++++++--------------------------------
 2 files changed, 83 insertions(+), 40 deletions(-)

diff --git a/sesman-test.el b/sesman-test.el
index b080070d8c..d6ca445b8a 100644
--- a/sesman-test.el
+++ b/sesman-test.el
@@ -245,6 +245,57 @@
 
    (should (= (length sesman-links-alist) 6))))
 
+
+;;; FILE PATHS
+
+(cl-defmethod sesman-project ((system (eql C)))
+  (directory-file-name default-directory))
+
+(ert-deftest sesman-symlinked-projects-tests ()
+  (let* ((dir1 (make-temp-file "1-" 'dir))
+         (dir2 (make-temp-file "2-" 'dir))
+         (dir1-link (format "%s/dir1" dir2 dir1)))
+    ;; dir1 link in dir2
+    (shell-command (format "ln -s %s %s"  dir1 dir1-link))
+
+    (let ((sesman-follow-symlinks nil)
+          (vc-follow-symlinks t))
+      (should (equal (sesman--expand-path dir1-link)
+                     dir1-link)))
+    (let ((sesman-follow-symlinks t)
+          (vc-follow-symlinks nil))
+      (should (equal (sesman--expand-path dir1-link)
+                     dir1)))
+    (let ((sesman-follow-symlinks 'vc)
+          (vc-follow-symlinks t))
+      (should (equal (sesman--expand-path dir1-link)
+                     dir1)))
+    (let ((sesman-follow-symlinks 'vc)
+          (vc-follow-symlinks nil))
+      (should (equal (sesman--expand-path dir1-link)
+                     dir1-link)))
+
+    (let ((sesman-follow-symlinks nil)
+          (default-directory dir1-link))
+      (should (equal (sesman-context 'project 'C)
+                     dir1-link)))
+    (let ((sesman-follow-symlinks t)
+          (default-directory dir1-link))
+      (should (equal (sesman-context 'project 'C)
+                     dir1)))
+    (let ((sesman-follow-symlinks 'vc)
+          (vc-follow-symlinks t)
+          (default-directory dir1-link))
+      (should (equal (sesman-context 'project 'C)
+                     dir1)))
+    (let ((sesman-follow-symlinks 'vc)
+          (vc-follow-symlinks nil)
+          (default-directory dir1-link))
+      (should (equal (sesman-context 'project 'C)
+                     dir1-link)))
+
+    (delete-directory dir1 t)
+    (delete-directory dir2 t)))
 
 (provide 'sesman-test)
 
diff --git a/sesman.el b/sesman.el
index 87106a9454..e426860e9b 100644
--- a/sesman.el
+++ b/sesman.el
@@ -66,27 +66,23 @@
   :group 'sesman)
 
 (defcustom sesman-use-friendly-sessions t
-  "If non-nil consider friendly sessions when searching for the current 
sessions.
+  "If non-nil consider friendly sessions when looking for current sessions.
 The definition of friendly sessions is system dependent but usually means
 sessions running in dependent projects."
   :group 'sesman
   :type 'boolean
   :package-version '(sesman . "0.3.2"))
 
-(defcustom sesman-follow-symlinks 'auto
-  "This variable determines whether symlinks should be followed.
-nil - Don't follow symlinks - use `expand-file-name' for expanding file paths.
-t - Follow symlinks - use `file-truename' for expanding file paths.
-'auto - Don't follow symlink unless it's under version control and
-`vc-follow-link' has nil value. Or `find-file-visit-truename' is non-nil."
+(defcustom sesman-follow-symlinks 'vc
+  "When non-nil, follow symlinks during the file expansion.
+When nil, don't follow symlinks. When 'vc, follow symlinks only when
+`vc-follow-symlinks' is non-nil. When t, always follow symlinks."
   :group 'sesman
-  :type '(choice (const :tag "Behave like `find-file'" auto)
+  :type '(choice (const :tag "Comply with `vc-follow-symlinks'" vc)
                  (const :tag "Don't follow symlinks"   nil)
                  (const :tag "Follow symlinks"         t))
-  :package-version '(sesman . "0.3.2"))
-(put 'sesman-follow-symlinks
-     'safe-local-variable
-     (lambda (x) (memq x '(auto nil t))))
+  :package-version '(sesman . "0.3.3"))
+(put 'sesman-follow-symlinks 'safe-local-variable (lambda (x) (memq x '(vc nil 
t))))
 
 ;; (defcustom sesman-disambiguate-by-relevance t
 ;;   "If t choose most relevant session in ambiguous situations, otherwise ask.
@@ -330,16 +326,6 @@ If SORT is non-nil, sort in relevance order."
 (defun sesman--lnk-value (lnk)
   (nth 2 lnk))
 
-(defun sesman--follow-symlink-p (filename)
-  "FILENAME predicate that tries to predict `find-file' behavior.
-It returns t if `find-file' will follow FILENAME symlink and nil if not."
-  (or find-file-visit-truename
-      (and vc-follow-symlinks
-           (let ((truename (file-truename filename)))
-             (and truename
-                  (not (equal truename filename))
-                  (vc-backend truename))))))
-
 
 ;;; User Interface
 
@@ -564,8 +550,9 @@ instead."
   (list :objects (cdr session)))
 
 (cl-defgeneric sesman-project (_system)
-  "Retrieve project root current directory (`default-directory') for SYSTEM.
-Return a string or nil if no project has been found." nil)
+  "Retrieve project root in current directory (`default-directory') for SYSTEM.
+Return a string or nil if no project has been found."
+  nil)
 
 (cl-defgeneric sesman-more-relevant-p (_system session1 session2)
   "Return non-nil if SESSION1 should be sorted before SESSION2.
@@ -934,18 +921,22 @@ buffers."
                           -1)))
                     (buffer-list)))))
 
+
 
 ;;; Contexts
 
-(defvar sesman--path-cache (make-hash-table :test #'equal))
 ;; path caching because file-truename is very slow
+(defvar sesman--path-cache (make-hash-table :test #'equal))
 (defun sesman--expand-path (path)
-  (if (or (eq sesman-follow-symlinks t)
-          (and (eq sesman-follow-symlinks 'auto)
-               (sesman--follow-symlink-p path)))
-   (or (gethash path sesman--path-cache)
-       (puthash path (file-truename path) sesman--path-cache))
-   (expand-file-name path)))
+  (if sesman-follow-symlinks
+      (let ((true-name (or (gethash path sesman--path-cache)
+                           (puthash path (file-truename path) 
sesman--path-cache))))
+        (if (or (eq sesman-follow-symlinks t)
+                vc-follow-symlinks)
+            true-name
+          ;; sesman-follow-symlinks is 'vc but vc-follow-symlinks is nil
+          (expand-file-name path)))
+    (expand-file-name path)))
 
 (cl-defgeneric sesman-context (_cxt-type _system)
   "Given SYSTEM and context type CXT-TYPE return the context.")
@@ -957,16 +948,17 @@ buffers."
   (sesman--expand-path default-directory))
 (cl-defmethod sesman-context ((_cxt-type (eql project)) system)
   "Return current project."
-  (let ((proj (or
-               (sesman-project (or system (sesman--system)))
-               ;; Normally we would use (project-roots (project-current)) but 
currently
-               ;; project-roots fails on nil and doesn't work on custom `('foo 
.
-               ;; "path/to/project"). So, use vc as a fallback and don't use 
project.el at
-               ;; all for now.
-               ;; NB: `vc-root-dir' doesn't work from symlinked files. Emacs 
Bug?
-               (vc-root-dir))))
+  (let* ((default-directory (sesman--expand-path default-directory))
+         (proj (or
+                (sesman-project (or system (sesman--system)))
+                ;; Normally we would use (project-roots (project-current)) but 
currently
+                ;; project-roots fails on nil and doesn't work on custom 
`('foo .
+                ;; "path/to/project"). So, use vc as a fallback and don't use 
project.el at
+                ;; all for now.
+                ;; NB: `vc-root-dir' doesn't work from symlinked files. Emacs 
Bug?
+                (vc-root-dir))))
     (when proj
-      (sesman--expand-path proj))))
+      (expand-file-name proj))))
 
 (cl-defgeneric sesman-relevant-context-p (_cxt-type cxt)
   "Non-nil if context CXT is relevant to current context of type CXT-TYPE.")