rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

utils: Add 'readlink*'. 

* guix/scripts/package.scm (readlink*): Move to...
* guix/utils.scm (readlink*): ... here.  New procedure.
This commit is contained in:
Ludovic Courtès 2015-10-26 20:01:45 +01:00
parent deaab8e314
commit d50cb56d9b
2 changed files with 28 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
guix/scripts/package.scm
View File

@ -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.

28
guix/utils.scm
View File

@ -82,6 +82,7 @@
fold-tree-leaves
split
cache-directory
readlink*
filtered-port
compressed-port
@ -710,6 +711,33 @@ elements after E."
(and=> (getenv "HOME")
(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.