guix package: Fix 'readlink*' implementation.
* guix/scripts/package.scm (readlink*): Fix to handle symlinks with relative targets. Taken from ld-wrapper2.in.
This commit is contained in:
parent
07c0b6e082
commit
ee8591990f
|
@ -730,13 +730,31 @@ doesn't need it."
|
|||
|
||||
(define (readlink* file)
|
||||
"Call 'readlink' until the result is not a symlink."
|
||||
(define %max-symlink-depth 50)
|
||||
|
||||
(let loop ((file file)
|
||||
(depth 0))
|
||||
(define (absolute target)
|
||||
(if (absolute-file-name? target)
|
||||
target
|
||||
(string-append (dirname file) "/" target)))
|
||||
|
||||
(if (>= depth %max-symlink-depth)
|
||||
file
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(readlink* (readlink file)))
|
||||
(values #t (readlink file)))
|
||||
(lambda args
|
||||
(if (= EINVAL (system-error-errno args))
|
||||
file
|
||||
(apply throw args)))))
|
||||
(let ((errno (system-error-errno args)))
|
||||
(if (or (= errno EINVAL))
|
||||
(values #f file)
|
||||
(apply throw args))))))
|
||||
(lambda (success? target)
|
||||
(if success?
|
||||
(loop (absolute target) (+ depth 1))
|
||||
file))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
Loading…
Reference in New Issue