From ee8591990fd38ee2860f0ab659b05052b10f14c6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Apr 2015 18:49:29 +0200 Subject: guix package: Fix 'readlink*' implementation. * guix/scripts/package.scm (readlink*): Fix to handle symlinks with relative targets. Taken from ld-wrapper2.in. --- guix/scripts/package.scm | 32 +++++++++++++++++++++++++------- 1 file changed, 25 insertions(+), 7 deletions(-) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a42452ae70..1e724b4e19 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -730,13 +730,31 @@ doesn't need it." (define (readlink* file) "Call 'readlink' until the result is not a symlink." - (catch 'system-error - (lambda () - (readlink* (readlink file))) - (lambda args - (if (= EINVAL (system-error-errno args)) - file - (apply throw args))))) + (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 () + (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)))))) ;;; -- cgit 1.4.1