02/02: build-system/gnu: 'compress-documentation' phase handles double symlinks.

[Ludovic Courtès]

civodul pushed a commit to branch core-updates
in repository guix.

commit facac292808d11d5e6ea528cc7dbe93595f62c9b
Author: Maxim Cournoyer <address@hidden>
Date:   Tue Apr 25 01:46:05 2017 +0900

    build-system/gnu: 'compress-documentation' phase handles double symlinks.
    
    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 <address@hidden>
---
 guix/build/gnu-build-system.scm | 36 ++++++++++++++++++++++++++++++------
 1 file changed, 30 insertions(+), 6 deletions(-)

diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 1786e2e..09f272e 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")