~ chicken-core (chicken-5) 00ed675fef88ed931c16859947ea5a79f62b1bf5

commit 00ed675fef88ed931c16859947ea5a79f62b1bf5
Author:     Moritz Heidkamp <moritz@twoticketsplease.de>
AuthorDate: Sat May 25 17:08:09 2013 +0200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Tue May 28 22:17:04 2013 +0200

    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.
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/posixunix.scm b/posixunix.scm
index a2776da3..27424fca 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)
+                                      target
+                                      (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)])