>From e98ed45bcfeca57d8d0a293da4ee335ea8d1ff4b Mon Sep 17 00:00:00 2001
From: Moritz Heidkamp <address@hidden>
Date: Sat, 25 May 2013 17:08:09 +0200
Subject: [PATCH 1/3] Improve read-symbolic-link canonicalization

Passing #t for the CANONICALIZE option of read-symbolic-link now behaves
like the --canonicalize option of readlink(1), i.e. it recursively
follows every symlink in every component of the given path. When called
like this, read-symbolic-link like readlink(1) now verifies that all
components exist.
---
 posixunix.scm | 43 +++++++++++++++++++++++++++++--------------
 1 file changed, 29 insertions(+), 14 deletions(-)

diff --git a/posixunix.scm b/posixunix.scm
index a2776da..6cdb4ef 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1241,21 +1241,36 @@ EOF
 
 (define-foreign-variable _filename_max int "FILENAME_MAX")
 
-(define read-symbolic-link
+(define ##sys#read-symbolic-link
   (let ((buf (make-string (fx+ _filename_max 1))))
-    (lambda (fname #!optional canonicalize)
-      (##sys#check-string fname 'read-symbolic-link)
-      (let ((len (##core#inline 
-		  "C_do_readlink"
-		  (##sys#make-c-string (##sys#expand-home-path fname) 'read-symbolic-link) buf)))
-	(if (fx< len 0)
-	    (if canonicalize
-		fname
-		(posix-error #:file-error 'read-symbolic-link "cannot read symbolic link" fname))
-	    (let ((pathname (substring buf 0 len)))
-	      (if (and canonicalize (symbolic-link? pathname))
-		  (read-symbolic-link pathname 'canonicalize)
-		  pathname ) ) ) ) ) ) )
+    (lambda (fname location)
+      (let ((len (##core#inline
+                  "C_do_readlink"
+                  (##sys#make-c-string fname location) buf)))
+        (if (fx< len 0)
+            (posix-error #:file-error location "cannot read symbolic link" fname)
+            (substring buf 0 len))))))
+
+(define (read-symbolic-link fname #!optional canonicalize)
+  (##sys#check-string fname 'read-symbolic-link)
+  (let ((fname (##sys#expand-home-path fname)))
+    (if canonicalize
+        (receive (base-origin base-directory directory-components) (decompose-directory fname)
+          (let loop ((components directory-components)
+                     (result (string-append (or base-origin "") (or base-directory ""))))
+            (if (null? components)
+                result
+                (let ((pathname (make-pathname result (car components))))
+                  (if (file-exists? pathname)
+                      (loop (cdr components)
+                            (if (symbolic-link? pathname)
+                                (let ((target (##sys#read-symbolic-link pathname 'read-symbolic-link)))
+                                  (if (absolute-pathname? target)
+                                      link
+                                      (make-pathname result target)))
+                                pathname))
+                      (##sys#signal-hook #:file-error 'read-symbolic-link "could not canonicalize path with symbolic links, component does not exist" pathname))))))
+        (##sys#read-symbolic-link fname 'read-symbolic-link))))
 
 (define file-link
   (let ([link (foreign-lambda int "link" c-string c-string)])
-- 
1.8.2.3