summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
authorMaxim Cournoyer <maxim.cournoyer@gmail.com>2017-04-25 01:46:05 +0900
committerLudovic Courtès <ludo@gnu.org>2017-05-30 21:56:20 +0200
commitfacac292808d11d5e6ea528cc7dbe93595f62c9b (patch)
treec39613fb242433b7b842272d0a74ccc6351b84d3 /guix/build
parenta30188f561af3f84a1da687dffb4192e621929fc (diff)
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 <ludo@gnu.org>
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/gnu-build-system.scm36
1 files changed, 30 insertions, 6 deletions
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")