nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

gnu: ld-wrapper: Extract symlink dereferencing. 

* gnu/packages/ld-wrapper.scm (readlink*, dereference-symlinks): New
  procedures.
  (pure-file-name?): Use it instead of local loop.
This commit is contained in:
Ludovic Courtès 2015-04-07 09:47:43 +02:00
parent bb146db14f
commit 41fc0eb900
1 changed files with 32 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
gnu/packages/ld-wrapper.scm
View File

@ -82,27 +82,45 @@ exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr (command-line))
;; Whether to emit debugging output. ;; Whether to emit debugging output.
(getenv "GUIX_LD_WRAPPER_DEBUG")) (getenv "GUIX_LD_WRAPPER_DEBUG"))
(define (pure-file-name? file) (define (readlink* file)
;; Return #t when FILE is the name of a file either within the store ;; Call 'readlink' until the result is not a symlink.
;; (possibly via a symlink) or within the build directory.
(define %max-symlink-depth 50) (define %max-symlink-depth 50)
(let loop ((file file) (let loop ((file file)
(depth 0)) (depth 0))
(or (not (string-prefix? "/" file)) (catch 'system-error
(string-prefix? %store-directory file) (lambda ()
(string-prefix? %temporary-directory file) (if (>= depth %max-symlink-depth)
(if %build-directory file
(string-prefix? %build-directory file) (loop (readlink file) (+ depth 1))))
(lambda args
(if (= EINVAL (system-error-errno args))
file
(apply throw args))))))
(define (dereference-symlinks file)
;; Same as 'readlink*' but return FILE if the symlink target is invalid or
;; FILE does not exist.
(catch 'system-error
(lambda ()
;; When used from a user environment, FILE may refer to ;; When used from a user environment, FILE may refer to
;; ~/.guix-profile/lib/libfoo.so, which is itself a symlink to the ;; ~/.guix-profile/lib/libfoo.so, which is itself a symlink to the
;; store. Check whether this is the case. ;; store. Check whether this is the case.
(let ((s (false-if-exception (lstat file)))) (readlink* file))
(and s (lambda args
(eq? 'symlink (stat:type s)) (if (= ENOENT (system-error-errno args))
(< depth %max-symlink-depth) file
(loop (readlink file) (+ 1 depth)))))))) (apply throw args)))))
(define (pure-file-name? file)
;; Return #t when FILE is the name of a file either within the store
;; (possibly via a symlink) or within the build directory.
(let ((file (dereference-symlinks file)))
(or (not (string-prefix? "/" file))
(string-prefix? %store-directory file)
(string-prefix? %temporary-directory file)
(and %build-directory
(string-prefix? %build-directory file)))))
(define (shared-library? file) (define (shared-library? file)
;; Return #t when FILE denotes a shared library. ;; Return #t when FILE denotes a shared library.