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

[Tino Calancha]

X-Debbugs-Cc: Drew Adams <drew.adams@oracle.com>
Severity: wishlist

Showing a broken/circular link w/ a special font might help users
to promptly identify a possible issue.


--8<-----------------------------cut here---------------start------------->8---
commit ecc6180be1afd795b5a998c7cbeb92dd1286a54b
Author: Tino Calancha <tino.calancha@gmail.com>
Date:   Wed Jan 15 21:51:17 2020 +0100

    dired: Show broken/circular links w/ different font
    
    * lisp/dired.el (dired-broken-symlink): New face.
    (dired-broken-symlink-face): Add variable for the 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 test.

diff --git a/etc/NEWS b/etc/NEWS
index 0e43c321d8..c3b183acf1 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -44,6 +44,9 @@ It was declared obsolete in Emacs 27.1.
 
 * Changes in Specialized Modes and Packages in Emacs 28.1
 
++++
+** Dired shows in a different color broken or circular links.
+
 
 * New Modes and Packages in Emacs 28.1
 
diff --git a/lisp/dired.el b/lisp/dired.el
index 689ad1fbfa..56edae4e1d 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -475,6 +475,17 @@ 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")
+
+(defvar dired-broken-symlink-face 'dired-broken-symlink
+  "Face name used for broken symbolic links.")
+
 (defface dired-special
   '((t (:inherit font-lock-variable-name-face)))
   "Face used for sockets, pipes, block devices and char devices."
@@ -538,6 +549,18 @@ 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 links to unexistent files or circular links
+                   (and (not (and truename (file-exists-p truename)))
+                       (search-forward-regexp ".+-> ?.+" end t))))
+               '(dired-move-to-filename)
+               nil
+               '(0 dired-broken-symlink-face)))
+   ;;
    ;; 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-with-temp-dirs
        (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 7, x86_64-pc-linux-gnu, GTK+ Version 3.24.5, cairo 
version 1.16.0)
 of 2020-01-15 built on calancha-pc.dy.bbexcite.jp
Repository revision: 576dfc8aa260957f4d0dc0c68cdcb8232a536f42
Repository branch: master
Windowing system distributor 'The X.Org Foundation', version 11.0.12004000
System Description: Debian GNU/Linux 10 (buster)