bug#39145: 28.0.50; dired: Show broken/circular links in different font

[Tino Calancha <tino.calancha@gmail.com>]

Glenn Morris <rgm@gnu.org> writes:

> Tino Calancha wrote:
>
>> +(defface dired-broken-symlink
>> +  '((((class color))
>> +     :foreground "yellow1" :background "red1" :weight bold)
>> +    (t :weight bold :slant italic :underline t))
>> +  "Face used for broken symbolic links."
>> +  :group 'dired-faces
>> +  :version "28.1")
>> +
>> +(defvar dired-broken-symlink-face 'dired-broken-symlink
>> +  "Face name used for broken symbolic links.")
>
> Why have a variable at all, why not just customize the face?
> (If it's just for consistency with existing dired stuff, consider
> breaking that consistency.)
It was for the consistency.
OK, I have dropped the variable.  Thank you!

I've been using this feature with joy since January.

Today I have updated the patch to match what my terminals (gnome
terminal and xterm) do: instead of
using the new font in the whole link line as I did before, that is
foo -> bar

now I only use dired-broken-symlink at 'foo' and 'bar' keeping '->' with
dired-symlink.

--8<-----------------------------cut here---------------start------------->8---
commit d250625b8f79a3b9273de6640f4840b5c8e54fe8
Author: Tino Calancha <ccalancha@suse.com>
Date:   Mon Aug 24 19:44:29 2020 +0200

    dired: Show broken/circular links w/ different face
    
    * lisp/dired.el (dired-broken-symlink): New face.
    (dired-font-lock-keywords) Use the new face for broken/circular links.
    
    * etc/NEWS (Changes in Specialized Modes and Packages in Emacs 28.1):
    Announce this change.
    
    * test/lisp/dired-tests.el (dired-test-dired-broken-symlink-face):
    Add a test.

diff --git a/etc/NEWS b/etc/NEWS
index a65852fcd0..53124b4253 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -235,6 +235,9 @@ time zones will use a form like "+0100" instead of "CET".
 
 ** Dired
 
++++
+*** Dired shows in a different color broken or circular links.
+
 +++
 *** New user option 'dired-maybe-use-globstar'.
 If set, enables globstar (recursive globbing) in shells that support
diff --git a/lisp/dired.el b/lisp/dired.el
index 94d3befda8..05f6bb0a68 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -534,6 +534,14 @@ dired-symlink
 (defvar dired-symlink-face 'dired-symlink
   "Face name used for symbolic links.")
 
+(defface dired-broken-symlink
+  '((((class color))
+     :foreground "yellow1" :background "red1" :weight bold)
+    (t :weight bold :slant italic :underline t))
+  "Face used for broken symbolic links."
+  :group 'dired-faces
+  :version "28.1")
+
 (defface dired-special
   '((t (:inherit font-lock-variable-name-face)))
   "Face used for sockets, pipes, block devices and char devices."
@@ -597,6 +605,20 @@ dired-font-lock-keywords
    (list dired-re-dir
 	 '(".+" (dired-move-to-filename) nil (0 dired-directory-face)))
    ;;
+   ;; Broken Symbolic link.
+   (list dired-re-sym
+         (list (lambda (end)
+                 (let* ((file (dired-file-name-at-point))
+                        (truename (ignore-errors (file-truename file))))
+                   ;; either not existent target or circular link
+                   (and (not (and truename (file-exists-p truename)))
+                        (search-forward-regexp "\\(.+\\) \\(->\\) ?\\(.+\\)" end t))))
+               '(dired-move-to-filename)
+               nil
+               '(1 'dired-broken-symlink)
+               '(2 dired-symlink-face)
+               '(3 'dired-broken-symlink)))
+   ;;
    ;; Symbolic link to a directory.
    (list dired-re-sym
          (list (lambda (end)
diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el
index 5c6649cba4..47f8809727 100644
--- a/test/lisp/dired-tests.el
+++ b/test/lisp/dired-tests.el
@@ -440,6 +440,31 @@ dired-test-bug27940
        (should (= 6 (length (dired-get-marked-files)))) ; All empty dirs but zeta-empty-dir deleted.
      (advice-remove 'read-answer 'dired-test-bug27940-advice))))
 
+(ert-deftest dired-test-dired-broken-symlink-face ()
+  "Test Dired fontifies correctly broken/circular links."
+  (let* ((dir (make-temp-file "test-symlink" 'dir))
+         (file (make-temp-file (expand-file-name "test-file" dir)))
+         (circular-link (expand-file-name "circular-link" dir))
+         (broken-link (expand-file-name "unexistent" dir))
+         (ok-link (expand-file-name file "ok-link")))
+    (unwind-protect
+        (with-current-buffer (dired dir)
+          (make-symbolic-link circular-link "circular-link")
+          (make-symbolic-link file "ok-link")
+          (make-symbolic-link broken-link "broken-link")
+          (dired-revert)
+          (sit-for 1)
+          ;; A circular link
+          (dired-goto-file circular-link)
+          (should (eq 'dired-broken-symlink (get-text-property (point) 'face)))
+          ;; A broken link
+          (dired-goto-file broken-link)
+          (should (eq 'dired-broken-symlink (get-text-property (point) 'face)))
+          ;; A valid link
+          (dired-goto-file ok-link)
+          (should-not (eq 'dired-broken-symlink (get-text-property (point) 'face))))
+      (delete-directory dir 'recursive))))
+
 
 (provide 'dired-tests)
 ;; dired-tests.el ends here

--8<-----------------------------cut here---------------end--------------->8---
In GNU Emacs 28.0.50 (build 14, x86_64-pc-linux-gnu, X toolkit, cairo version 1.16.0, Xaw scroll bars)
 of 2020-08-24 built on localhost.example.com
Repository revision: 88795c52ff13203dda5940ed5defc26ce2c20e5e
Repository branch: master
Windowing system distributor 'The X.Org Foundation', version 11.0.12008000
System Description: openSUSE Tumbleweed