From d50cb56d9b58f3e1605f59b35ce99942c3b70d24 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Oct 2015 20:01:45 +0100 Subject: utils: Add 'readlink*'. * guix/scripts/package.scm (readlink*): Move to... * guix/utils.scm (readlink*): ... here. New procedure. --- guix/scripts/package.scm | 28 ---------------------------- 1 file changed, 28 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 804ca954f2..ee45cddedd 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -612,34 +612,6 @@ doesn't need it." (add-indirect-root store absolute)) -(define (readlink* file) - "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 - (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)))))) - ;;; ;;; Entry point. -- cgit v1.2.3