ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 23:46:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
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>
This commit is contained in:
Maxim Cournoyer 2017-04-25 01:46:05 +09:00 committed by Ludovic Courtès
parent a30188f561
commit facac29280
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 30 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
guix/build/gnu-build-system.scm
View file

@ -521,6 +521,25 @@ (define (has-links? file)
;; 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 @@ (define (maybe-compress-directory directory regexp)
;; 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")