Hi all, The find-files change by Mario uncovered a bug in the Windows implementation of the posix create-directory procedure: if you pass #t as the second argument (so it will create the parent directory components), it will accidentally skip the first component. This is rarely a problem with absolute paths, as most often you won't be creating something directly under the root (though you could do so), but with relative paths this means breakage happens really easily.
The attached patches fix this problem (that's patch 0001, which should go into chicken-5, master *and* prerelease, IMO!) and two more problems. Patch 0002 fixes the find-files test itself so that it will omit the symlink stuff on Windows because that's unsupported there (should go into chicken-5 and master only), and patch 0003 fixes the executable-pathname test on mingw-msys, where the shell script will use forward slashes while the executable-pathname procedure will return paths with backslashes. This final patch should only go into chicken-5, as master does not have this new procedure or the test. Cheers, Peter
From a4e6af224add2513f99641f56c5a0d41a4f75f48 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sat, 20 Jun 2015 14:08:26 +0200
Subject: [PATCH 1/3] Fix create-directory parent dir creation on Windows.
When passing #t as the second argument to make create-directory behave
like "mkdir -p", on Windows there was a small mistake in the logic so it
would never actually create the topmost parent directory, only those at
level 2 and below. This was exposed by the find-files test which uses
this feature of create-directory.
Instead of having differing implementations, we move the UNIX
implementation into posix-common; it recursively decomposes pathnames
using standard procedures that already deal with the difference in path
separator. Both use C_mkdir(), which is defined in a platform-specific
way (but using a common API) at the top of each corresponding platform's
posix file.
---
NEWS | 2 ++
posix-common.scm | 19 ++++++++++++++++++-
posixunix.scm | 18 ------------------
posixwin.scm | 28 ----------------------------
4 files changed, 20 insertions(+), 47 deletions(-)
diff --git a/NEWS b/NEWS
index b898bc0..0d72b4f 100644
--- a/NEWS
+++ b/NEWS
@@ -62,6 +62,8 @@
to Seth Alves).
- file-mkstemp now works correctly on Windows, it now returns valid
file descriptors (#819, thanks to Michele La Monaca).
+ - create-directory on Windows now creates all intermediate
+ directories when passed #t as second parameter.
- Runtime system:
- Removed several deprecated, undocumented parts of the C interface:
diff --git a/posix-common.scm b/posix-common.scm
index 8b3e4e5..b0280ba 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -444,6 +444,24 @@ EOF
(rmdir name))
(rmdir name))))
+(define-inline (*create-directory loc name)
+ (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name loc)))
+ (posix-error #:file-error loc "cannot create directory" name)) )
+
+(define create-directory
+ (lambda (name #!optional parents?)
+ (##sys#check-string name 'create-directory)
+ (unless (or (fx= 0 (##sys#size name))
+ (file-exists? name))
+ (if parents?
+ (let loop ((dir (let-values (((dir file ext) (decompose-pathname name)))
+ (if file (make-pathname dir file ext) dir))))
+ (when (and dir (not (directory? dir)))
+ (loop (pathname-directory dir))
+ (*create-directory 'create-directory dir)) )
+ (*create-directory 'create-directory name) ) )
+ name))
+
(define directory
(lambda (#!optional (spec (current-directory)) show-dotfiles?)
(##sys#check-string spec 'directory)
@@ -472,7 +490,6 @@ EOF
(loop)
(cons file (loop)) ) ) ) ) ) ) ) )
-
;;; Filename globbing:
(define glob
diff --git a/posixunix.scm b/posixunix.scm
index 5e8d36f..6f7ec5b 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -611,24 +611,6 @@ EOF
;;; Directory stuff:
-(define-inline (*create-directory loc name)
- (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name loc)))
- (posix-error #:file-error loc "cannot create directory" name)) )
-
-(define create-directory
- (lambda (name #!optional parents?)
- (##sys#check-string name 'create-directory)
- (unless (or (fx= 0 (##sys#size name))
- (file-exists? name))
- (if parents?
- (let loop ((dir (let-values (((dir file ext) (decompose-pathname name)))
- (if file (make-pathname dir file ext) dir))))
- (when (and dir (not (directory? dir)))
- (loop (pathname-directory dir))
- (*create-directory 'create-directory dir)) )
- (*create-directory 'create-directory name) ) )
- name))
-
(define change-directory
(lambda (name)
(##sys#check-string name 'change-directory)
diff --git a/posixwin.scm b/posixwin.scm
index 83794aa..8ca0638 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -803,34 +803,6 @@ EOF
;;; Directory stuff:
-(define-inline (create-directory-helper name)
- (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name 'create-directory)))
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'create-directory
- "cannot create directory" name)))
-
-(define-inline (create-directory-helper-silent name)
- (unless (##sys#file-exists? name #f #t #f)
- (create-directory-helper name)))
-
-(define-inline (create-directory-helper-parents name)
- (let* ((l (string-split name "/\\"))
- (c (car l)))
- (for-each
- (lambda (x)
- (set! c (string-append c "/" x))
- (create-directory-helper-silent c))
- (cdr l))))
-
-(define create-directory
- (lambda (name #!optional parents?)
- (##sys#check-string name 'create-directory)
- (let ((name name))
- (if parents?
- (create-directory-helper-parents name)
- (create-directory-helper name))
- name)))
-
(define change-directory
(lambda (name)
(##sys#check-string name 'change-directory)
--
2.1.4
From c51ae9ce18fecf0deb8c802fb5b5385fd670557c Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sat, 20 Jun 2015 14:36:28 +0200
Subject: [PATCH 2/3] Skip symlink tests in find-files test on Windows, which
can't handle symlinks
---
tests/test-find-files.scm | 82 ++++++++++++++++++++++++++++++-----------------
1 file changed, 53 insertions(+), 29 deletions(-)
diff --git a/tests/test-find-files.scm b/tests/test-find-files.scm
index 891ab92..c3ef3e4 100644
--- a/tests/test-find-files.scm
+++ b/tests/test-find-files.scm
@@ -23,26 +23,30 @@
(change-directory "find-files-test-dir")
-(create-symbolic-link "dir-link-target" "dir-link-name")
+(cond-expand
+ ((and windows (not cygwin))) ; Cannot handle symlinks
+ (else (create-symbolic-link "dir-link-target" "dir-link-name")))
(test-begin "find-files")
(test-equal "no keyword args"
(find-files ".")
- '("./foo/bar/baz"
+ `("./foo/bar/baz"
"./foo/bar"
"./foo"
"./dir-link-target/foo"
"./dir-link-target/bar"
"./dir-link-target"
"./file1"
- "./dir-link-name"
+ ,@(cond-expand
+ ((and windows (not cygwin)) '())
+ (else '("./dir-link-name")))
"./file2")
file-list=?)
(test-equal "dotfiles: #t"
(find-files "." dotfiles: #t)
- '("./foo/bar/baz/.quux"
+ `("./foo/bar/baz/.quux"
"./foo/bar/baz"
"./foo/bar"
"./foo/.x"
@@ -51,108 +55,126 @@
"./dir-link-target/bar"
"./dir-link-target"
"./file1"
- "./dir-link-name"
+ ,@(cond-expand
+ ((and windows (not cygwin)) '())
+ (else '("./dir-link-name")))
"./file2")
file-list=?)
(test-equal "follow-symlinks: #t"
(find-files "." follow-symlinks: #t)
- '("./foo/bar/baz"
+ `("./foo/bar/baz"
"./foo/bar"
"./foo"
"./dir-link-target/foo"
"./dir-link-target/bar"
"./dir-link-target"
"./file1"
- "./dir-link-name/foo"
- "./dir-link-name/bar"
- "./dir-link-name"
+ ,@(cond-expand
+ ((and windows (not cygwin)) '())
+ (else '("./dir-link-name/foo"
+ "./dir-link-name/bar"
+ "./dir-link-name")))
"./file2")
file-list=?)
(test-equal "limit: 1"
(find-files "." limit: 1)
- '("./foo/bar"
+ `("./foo/bar"
"./foo"
"./dir-link-target/foo"
"./dir-link-target/bar"
"./dir-link-target"
"./file1"
- "./dir-link-name"
+ ,@(cond-expand
+ ((and windows (not cygwin)) '())
+ (else '("./dir-link-name")))
"./file2")
file-list=?)
(test-equal "limit: 1 follow-symlinks: #t"
(find-files "." limit: 1 follow-symlinks: #t)
- '("./foo/bar"
+ `("./foo/bar"
"./foo"
"./dir-link-target/foo"
"./dir-link-target/bar"
"./dir-link-target"
"./file1"
- "./dir-link-name/foo"
- "./dir-link-name/bar"
- "./dir-link-name"
+ ,@(cond-expand
+ ((and windows (not cygwin)) '())
+ (else '("./dir-link-name/foo"
+ "./dir-link-name/bar"
+ "./dir-link-name")))
"./file2")
file-list=?)
(test-equal "limit: 2"
(find-files "." limit: 2)
- '("./foo/bar/baz"
+ `("./foo/bar/baz"
"./foo/bar"
"./foo"
"./dir-link-target/foo"
"./dir-link-target/bar"
"./dir-link-target"
"./file1"
- "./dir-link-name"
+ ,@(cond-expand
+ ((and windows (not cygwin)) '())
+ (else '("./dir-link-name")))
"./file2")
file-list=?)
(test-equal "limit: 2 follow-symlinks: #t"
(find-files "." limit: 2 follow-symlinks: #t)
- '("./foo/bar/baz"
+ `("./foo/bar/baz"
"./foo/bar"
"./foo"
"./dir-link-target/foo"
"./dir-link-target/bar"
"./dir-link-target"
"./file1"
- "./dir-link-name/foo"
- "./dir-link-name/bar"
- "./dir-link-name"
+ ,@(cond-expand
+ ((and windows (not cygwin)) '())
+ (else '("./dir-link-name/foo"
+ "./dir-link-name/bar"
+ "./dir-link-name")))
"./file2")
file-list=?)
(test-equal "test: (lambda (f) (directory? f))"
(find-files "." test: (lambda (f) (directory? f)))
- '("./foo/bar/baz"
+ `("./foo/bar/baz"
"./foo/bar"
"./foo"
"./dir-link-target"
- "./dir-link-name")
+ ,@(cond-expand
+ ((and windows (not cygwin)) '())
+ (else '("./dir-link-name"))))
file-list=?)
(test-equal "test: (lambda (f) (directory? f)) action: (lambda (f p) (cons (string-append \"--\" f) p))"
(find-files "."
test: (lambda (f) (directory? f))
action: (lambda (f p) (cons (string-append "--" f) p)))
- '("--./foo/bar/baz"
+ `("--./foo/bar/baz"
"--./foo/bar"
"--./foo"
"--./dir-link-target"
- "--./dir-link-name")
+ ,@(cond-expand
+ ((and windows (not cygwin)) '())
+ (else '("--./dir-link-name"))))
file-list=?)
(test-equal "dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t"
(find-files "." dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t)
- '("./foo/bar/baz/.quux"
+ `("./foo/bar/baz/.quux"
"./foo/bar/baz"
"./foo/bar"
"./foo/.x"
"./foo"
"./dir-link-target"
- "./dir-link-name")
+ ,@(cond-expand
+ ((and windows (not cygwin)) '())
+ (else '("./dir-link-name"))))
file-list=?)
(test-equal "dotfiles: #t test: (lambda (f) (directory? f)) follow-symlinks: #t limit: 1"
@@ -161,11 +183,13 @@
test: (lambda (f) (directory? f))
follow-symlinks: #t
limit: 1)
- '("./foo/bar"
+ `("./foo/bar"
"./foo/.x"
"./foo"
"./dir-link-target"
- "./dir-link-name")
+ ,@(cond-expand
+ ((and windows (not cygwin)) '())
+ (else '("./dir-link-name"))))
file-list=?)
(test-end "find-files")
--
2.1.4
From b6e15afd7383dd9d96f503a55f20cfdc41117fa5 Mon Sep 17 00:00:00 2001 From: Peter Bex <pe...@more-magic.net> Date: Sat, 20 Jun 2015 14:59:54 +0200 Subject: [PATCH 3/3] Fix executable-tests on mingw-msys for path separator --- tests/executable-tests.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/tests/executable-tests.scm b/tests/executable-tests.scm index 78695ec..ef391d5 100644 --- a/tests/executable-tests.scm +++ b/tests/executable-tests.scm @@ -2,10 +2,13 @@ (include "test.scm") -(use files posix) +(use files posix data-structures) (define program-path - (car (command-line-arguments))) + (cond-expand + ((and windows (not cygwin)) + (string-translate (car (command-line-arguments)) "/" "\\")) + (else (car (command-line-arguments))))) (define (read-symbolic-link* p) (cond-expand -- 2.1.4
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
