From facac292808d11d5e6ea528cc7dbe93595f62c9b Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Tue, 25 Apr 2017 01:46:05 +0900
Subject: build-system/gnu: 'compress-documentation' phase handles double
 symlinks.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

The compress-documentation phase was breaking recursive symbolic links used
for manuals, which was made visible by the `find-files' call in the recently
added `manual-database' profile hook.  See <http://bugs.gnu.org/26771>.

* guix/build/gnu-build-system.scm (compress-documentation)
[points-to-symbolic-link?]: New procedure.
[maybe-compress-directory]: Use `points-to-symbolic-link?' to filter out
symbolic links that shouldn't be retargetted, and re-order the calls to
`retarget-symlink' and `documentation-compressor'.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>
---
 guix/build/gnu-build-system.scm | 36 ++++++++++++++++++++++++++++++------
 1 file changed, 30 insertions(+), 6 deletions(-)

(limited to 'guix')

diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 1786e2e3c9..09f272edee 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -521,6 +521,25 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
     ;; Return #t if FILE has hard links.
     (> (stat:nlink (lstat file)) 1))
 
+  (define (points-to-symlink? symlink)
+    ;; Return #t if SYMLINK points to another symbolic link.
+    (let* ((target (readlink symlink))
+           (target-absolute (if (string-prefix? "/" target)
+                                target
+                                (string-append (dirname symlink)
+                                               "/" target))))
+      (catch 'system-error
+        (lambda ()
+          (symbolic-link? target-absolute))
+        (lambda args
+          (if (= ENOENT (system-error-errno args))
+              (begin
+                (format (current-error-port)
+                        "The symbolic link '~a' target is missing: '~a'\n"
+                        symlink target-absolute)
+                #f)
+              (apply throw args))))))
+
   (define (maybe-compress-directory directory regexp)
     (or (not (directory-exists? directory))
         (match (find-files directory regexp)
@@ -538,12 +557,17 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
                ;; Compress the non-symlink files, and adjust symlinks to refer
                ;; to the compressed files.  Leave files that have hard links
                ;; unchanged ('gzip' would refuse to compress them anyway.)
-               (and (zero? (apply system* documentation-compressor
-                                  (append documentation-compressor-flags
-                                          (remove has-links? regular-files))))
-                    (every retarget-symlink
-                           (filter (cut string-match regexp <>)
-                                   symlinks)))))))))
+               ;; Also, do not retarget symbolic links pointing to other
+               ;; symbolic links, since these are not compressed.
+               (and (every retarget-symlink
+                           (filter (lambda (symlink)
+                                     (and (not (points-to-symlink? symlink))
+                                          (string-match regexp symlink)))
+                                   symlinks))
+                    (zero?
+                     (apply system* documentation-compressor
+                            (append documentation-compressor-flags
+                                    (remove has-links? regular-files)))))))))))
 
   (define (maybe-compress output)
     (and (maybe-compress-directory (string-append output "/share/man")
-- 
cgit v1.2.3