utils: Add 'readlink*'.
* guix/scripts/package.scm (readlink*): Move to... * guix/utils.scm (readlink*): ... here. New procedure.
This commit is contained in:
parent
deaab8e314
commit
d50cb56d9b
|
@ -612,34 +612,6 @@ doesn't need it."
|
||||||
|
|
||||||
(add-indirect-root store absolute))
|
(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.
|
;;; Entry point.
|
||||||
|
|
|
@ -82,6 +82,7 @@
|
||||||
fold-tree-leaves
|
fold-tree-leaves
|
||||||
split
|
split
|
||||||
cache-directory
|
cache-directory
|
||||||
|
readlink*
|
||||||
|
|
||||||
filtered-port
|
filtered-port
|
||||||
compressed-port
|
compressed-port
|
||||||
|
@ -710,6 +711,33 @@ elements after E."
|
||||||
(and=> (getenv "HOME")
|
(and=> (getenv "HOME")
|
||||||
(cut string-append <> "/.cache/guix"))))
|
(cut string-append <> "/.cache/guix"))))
|
||||||
|
|
||||||
|
(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))))))
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Source location.
|
;;; Source location.
|
||||||
|
|
Loading…
Reference in New Issue