Mario Domenech Goulart <mario.goul...@gmail.com> writes: > Maybe "readlink -f" ?
OK, Peter found that even that is not portable so I changed the test itself to do the path canonicalization. Turns out that while the posix unit's read-symbolic-link has a CANONICALIZE option it doesn't quite behave like the readlink(1) program. So I went ahead and adapted its behavior to match that. I also noticed that the types.db entry for read-symbolic-link did not include that optional argument so I took it as an opportunity to fix this, as well. Moritz
>From e98ed45bcfeca57d8d0a293da4ee335ea8d1ff4b Mon Sep 17 00:00:00 2001 From: Moritz Heidkamp <mor...@twoticketsplease.de> 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
>From a7de20ed3d344f9fcaa981fd746091624869be60 Mon Sep 17 00:00:00 2001 From: Moritz Heidkamp <mor...@twoticketsplease.de> Date: Sat, 25 May 2013 17:27:55 +0200 Subject: [PATCH 2/3] Fix read-symbolic-link types.db entry The optional CANONICALIZE argument was missing. --- types.db | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/types.db b/types.db index 01d84e2..c061092 100644 --- a/types.db +++ b/types.db @@ -1765,7 +1765,7 @@ (prot/none fixnum) (prot/read fixnum) (prot/write fixnum) -(read-symbolic-link (#(procedure #:clean #:enforce) read-symbolic-link (string) string)) +(read-symbolic-link (#(procedure #:clean #:enforce) read-symbolic-link (string #!optional boolean) string)) (regular-file? (#(procedure #:clean #:enforce) regular-file? ((or string fixnum)) boolean)) (seconds->local-time (#(procedure #:clean #:enforce) seconds->local-time (#!optional number) (vector fixnum fixnum fixnum fixnum fixnum fixnum fixnum fixnum boolean fixnum))) (seconds->string (#(procedure #:clean #:enforce) seconds->string (#!optional number) string)) -- 1.8.2.3
>From a3cea67616c7d50092e20374ebc47176c7fee660 Mon Sep 17 00:00:00 2001 From: Moritz Heidkamp <mor...@twoticketsplease.de> Date: Sat, 25 May 2013 17:31:12 +0200 Subject: [PATCH 3/3] Make tests work from symlinked paths The private repository path tests didn't work when run from inside a path containing symlinks because runtests.sh didn't expand symlinks while the -private-repository mechanism does. This lead the test assertion which compares the two paths to fail. --- tests/private-repository-test.scm | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/tests/private-repository-test.scm b/tests/private-repository-test.scm index 9ad524c..6a4f5c7 100644 --- a/tests/private-repository-test.scm +++ b/tests/private-repository-test.scm @@ -1,10 +1,15 @@ ;;;; private-repository-test.scm -(use files) +(use files posix) -(define repo (normalize-pathname (repository-path))) -(define dir (normalize-pathname (car (command-line-arguments)))) +(define read-symbolic-link* + (cond-expand + ((and windows (not cygwin)) (lambda (x) x)) + (else read-symbolic-link))) + +(define repo (normalize-pathname (read-symbolic-link* (repository-path) #t))) +(define dir (normalize-pathname (read-symbolic-link* (car (command-line-arguments)) #t))) (print (list dir repo)) -- 1.8.2.3
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
