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:
Ludovic Courtès 2015-04-19 18:49:29 +02:00
parent 07c0b6e082
commit ee8591990f
1 changed files with 25 additions and 7 deletions

View File

@ -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."
(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 (catch 'system-error
(lambda () (lambda ()
(readlink* (readlink file))) (values #t (readlink file)))
(lambda args (lambda args
(if (= EINVAL (system-error-errno args)) (let ((errno (system-error-errno args)))
file (if (or (= errno EINVAL))
(apply throw args))))) (values #f file)
(apply throw args))))))
(lambda (success? target)
(if success?
(loop (absolute target) (+ depth 1))
file))))))
;;; ;;;