04/05: guix package: Fix 'readlink*' implementation.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit ee8591990fd38ee2860f0ab659b05052b10f14c6
Author: Ludovic Courtès <address@hidden>
Date:   Sun Apr 19 18:49:29 2015 +0200

    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 files changed, 25 insertions(+), 7 deletions(-)

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index a42452a..1e724b4 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))))))
 
 
 ;;;