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)
|
(define (readlink* file)
|
||||||
"Call 'readlink' until the result is not a symlink."
|
"Call 'readlink' until the result is not a symlink."
|
||||||
(catch 'system-error
|
(define %max-symlink-depth 50)
|
||||||
(lambda ()
|
|
||||||
(readlink* (readlink file)))
|
(let loop ((file file)
|
||||||
(lambda args
|
(depth 0))
|
||||||
(if (= EINVAL (system-error-errno args))
|
(define (absolute target)
|
||||||
file
|
(if (absolute-file-name? target)
|
||||||
(apply throw args)))))
|
target
|
||||||
|
(string-append (dirname file) "/" target)))
|
||||||
|
|
||||||
|
(if (>= depth %max-symlink-depth)
|
||||||
|
file
|
||||||
|
(call-with-values
|
||||||
|
(lambda ()
|
||||||
|
(catch 'system-error
|
||||||
|
(lambda ()
|
||||||
|
(values #t (readlink file)))
|
||||||
|
(lambda 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