[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
04/05: guix package: Fix 'readlink*' implementation.
From: |
Ludovic Courtès |
Subject: |
04/05: guix package: Fix 'readlink*' implementation. |
Date: |
Sun, 19 Apr 2015 21:35:01 +0000 |
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))))))
;;;