01/07: gnu: ld-wrapper: Extract symlink dereferencing.

[Ludovic Courtès]

civodul pushed a commit to branch core-updates
in repository guix.

commit 41fc0eb90056c1f0aad41a971bf0c5eff5a72c97
Author: Ludovic Courtès <address@hidden>
Date:   Tue Apr 7 09:47:43 2015 +0200

    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.
---
 gnu/packages/ld-wrapper.scm |   46 +++++++++++++++++++++++++++++-------------
 1 files changed, 32 insertions(+), 14 deletions(-)

diff --git a/gnu/packages/ld-wrapper.scm b/gnu/packages/ld-wrapper.scm
index cc533f5..9d35a7b 100644
--- a/gnu/packages/ld-wrapper.scm
+++ b/gnu/packages/ld-wrapper.scm
@@ -82,27 +82,45 @@ exec @GUILE@ -c "(load-compiled \"@address@hidden") (apply 
$main (cdr (command-line))
   ;; Whether to emit debugging output.
   (getenv "GUIX_LD_WRAPPER_DEBUG"))
 
-(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.
+(define (readlink* file)
+  ;; Call 'readlink' until the result is not a symlink.
   (define %max-symlink-depth 50)
 
   (let loop ((file  file)
              (depth 0))
+    (catch 'system-error
+      (lambda ()
+        (if (>= depth %max-symlink-depth)
+            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
+      ;; ~/.guix-profile/lib/libfoo.so, which is itself a symlink to the
+      ;; store.  Check whether this is the case.
+      (readlink* file))
+    (lambda args
+      (if (= ENOENT (system-error-errno args))
+          file
+          (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)
-        (if %build-directory
-            (string-prefix? %build-directory file)
-
-            ;; When used from a user environment, FILE may refer to
-            ;; ~/.guix-profile/lib/libfoo.so, which is itself a symlink to the
-            ;; store.  Check whether this is the case.
-            (let ((s (false-if-exception (lstat file))))
-              (and s
-                   (eq? 'symlink (stat:type s))
-                   (< depth %max-symlink-depth)
-                   (loop (readlink file) (+ 1 depth))))))))
+        (and %build-directory
+             (string-prefix? %build-directory file)))))
 
 (define (shared-library? file)
   ;; Return #t when FILE denotes a shared library.