~ chicken-core (chicken-5) cf915c96e67c641b12b01782a7e35d617ff2724c
commit cf915c96e67c641b12b01782a7e35d617ff2724c
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Tue Oct 10 21:45:56 2017 +1300
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Wed Oct 11 21:00:27 2017 +0200
Add a more thorough workaround for stat() issues on MinGW
MinGW's stat(2) syscall is badly behaved with respect to trailing
slashes in pathnames, so we add a drop-in replacement ("C_stat") in
chicken.h that smoothes over these problems on MinGW, MSYS, and MSYS2.
In particular, this replacement will strip trailing slashes and retry
when the built-in stat(2) yields ENOENT, since paths like "<dir>//" will
cause MinGW's version to fail (incorrectly). It will also return -1 when
given a non-directory pathname that includes a trailing slash, since the
built-in version will actually succeed in this case when it should
instead fail with errno set to ENOTDIR.
Note that we must attempt to stat the given filename at least once
before stripping slashes, since there are some valid paths (e.g. "C:/"
or "\\") that require them to be present in order for the call to
succeed.
The preexisting stat macros in posix*.scm have been given "u" and "i"
prefixes to avoid name collisions with the new wrapper, and to indicate
their proper usage.
This commit also adds a test script to check for these and other similar
problems on all platforms. The invocation of this script in runtests.sh
is a bit unusual, passing "//" as an argument instead of "/" when
running under MSYS*. This is because a single "/" will expand to the
MSYS installation's root directory, for example "C:/MinGW/msys/1.0"; the
second slash effectively escapes the first and disables this behaviour.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/chicken.h b/chicken.h
index 57f99a2c..3aeb0028 100644
--- a/chicken.h
+++ b/chicken.h
@@ -120,6 +120,7 @@
/* Headers */
#include <ctype.h>
+#include <errno.h>
#include <inttypes.h>
#include <limits.h>
#include <math.h>
@@ -132,6 +133,7 @@
#include <time.h>
#include <unistd.h>
#include <sys/types.h>
+#include <sys/stat.h>
/* Byteorder in machine word */
@@ -3490,6 +3492,47 @@ inline static size_t C_strlcat(char *dst, const char *src, size_t sz)
}
#endif
+/*
+ * MinGW's stat() is less than ideal in a couple of ways, so we provide a
+ * wrapper that:
+ *
+ * 1. Strips all trailing slashes and retries on failure, since stat() will
+ * yield ENOENT when given two (on MSYS) or more (on MinGW and MSYS2).
+ * 2. Fails with ENOTDIR when given a path to a non-directory file that ends
+ * in a slash, since in this case MinGW's stat() will succeed but return a
+ * non-directory mode in buf.st_mode.
+ */
+#ifndef __MINGW32__
+# define C_stat stat
+#else
+inline static int C_stat(const char *path, struct stat *buf)
+{
+ size_t len = C_strlen(path);
+ char slash = len && C_strchr("\\/", path[len - 1]), *str;
+
+ if(stat(path, buf) == 0)
+ goto dircheck;
+
+ if(slash && errno == ENOENT) {
+ C_strlcpy((str = C_alloca(len + 1)), path, len + 1);
+ while(len > 1 && C_strchr("\\/", path[--len]))
+ str[len] = '\0';
+ if(stat(str, buf) == 0)
+ goto dircheck;
+ }
+
+ return -1;
+
+dircheck:
+ if(slash && !S_ISDIR(buf->st_mode)) {
+ errno = ENOTDIR;
+ return -1;
+ }
+
+ return 0;
+}
+#endif
+
/* Safe realpath usage depends on a reliable PATH_MAX. */
#ifdef PATH_MAX
# define C_realpath realpath
diff --git a/distribution/manifest b/distribution/manifest
index f84ecf28..5ce932d5 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -146,6 +146,7 @@ tests/embedded3.c
tests/embedded4.scm
tests/executable-tests.scm
tests/condition-tests.scm
+tests/file-access-tests.scm
tests/fixnum-tests.scm
tests/numbers-string-conversion-tests.scm
tests/numbers-test.scm
diff --git a/library.scm b/library.scm
index d75635a9..584e539c 100644
--- a/library.scm
+++ b/library.scm
@@ -2749,20 +2749,6 @@ EOF
(define (##sys#port-data port) (##sys#slot port 9))
(define (##sys#set-port-data! port data) (##sys#setslot port 9 data))
-(define ##sys#platform-fixup-pathname
- (let* ([bp (string->symbol ((##core#primitive "C_build_platform")))]
- [fixsuffix (eq? bp 'mingw32)])
- (lambda (name)
- (if fixsuffix
- (let ([end (fx- (##sys#size name) 1)])
- (if (fx>= end 0)
- (let ([c (##core#inline "C_subchar" name end)])
- (if (or (eq? c #\\) (eq? c #\/))
- (##sys#substring name 0 end)
- name) )
- name) )
- name) ) ) )
-
(define open-input-file)
(define open-output-file)
(define close-input-port)
@@ -2858,17 +2844,11 @@ EOF
(define (file-exists? name)
(##sys#check-string name 'file-exists?)
- (and (##sys#file-exists?
- (##sys#platform-fixup-pathname name)
- #f #f 'file-exists?)
- name) )
+ (and (##sys#file-exists? name #f #f 'file-exists?) name))
(define (directory-exists? name)
(##sys#check-string name 'directory-exists?)
- (and (##sys#file-exists?
- (##sys#platform-fixup-pathname name)
- #f #t 'directory-exists?)
- name) )
+ (and (##sys#file-exists? name #f #t 'directory-exists?) name))
(define (##sys#flush-output port)
((##sys#slot (##sys#slot port 2) 5) port) ; flush-output
diff --git a/posix-common.scm b/posix-common.scm
index b0a8b5be..553725a9 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -28,9 +28,6 @@
(foreign-declare #<<EOF
#include <signal.h>
-#include <errno.h>
-
-#include <sys/stat.h>
static int C_not_implemented(void);
int C_not_implemented() { return -1; }
@@ -41,8 +38,9 @@ static C_TLS struct stat C_statbuf;
#define C_stat_type (C_statbuf.st_mode & S_IFMT)
#define C_stat_perm (C_statbuf.st_mode & ~S_IFMT)
-#define C_stat(fn) C_fix(stat((char *)C_data_pointer(fn), &C_statbuf))
-#define C_fstat(f) C_fix(fstat(C_unfix(f), &C_statbuf))
+
+#define C_u_i_stat(fn) C_fix(C_stat((char *)C_data_pointer(fn), &C_statbuf))
+#define C_u_i_fstat(fd) C_fix(fstat(C_unfix(fd), &C_statbuf))
#ifndef S_IFSOCK
# define S_IFSOCK 0140000
@@ -248,16 +246,13 @@ EOF
(stat-mode S_IFIFO)
(define (stat file link err loc)
- (let ((r (cond ((fixnum? file) (##core#inline "C_fstat" file))
- ((port? file) (##core#inline "C_fstat" (port->fileno file)))
+ (let ((r (cond ((fixnum? file) (##core#inline "C_u_i_fstat" file))
+ ((port? file) (##core#inline "C_u_i_fstat" (port->fileno file)))
((string? file)
- (let ((path (##sys#make-c-string
- (##sys#platform-fixup-pathname
- file)
- loc)))
+ (let ((path (##sys#make-c-string file loc)))
(if link
- (##core#inline "C_lstat" path)
- (##core#inline "C_stat" path) ) ) )
+ (##core#inline "C_u_i_lstat" path)
+ (##core#inline "C_u_i_stat" path))))
(else
(##sys#signal-hook
#:type-error loc "bad argument type - not a fixnum, port or string" file)) ) ) )
diff --git a/posixunix.scm b/posixunix.scm
index 7f8bc239..5ac48082 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -149,7 +149,7 @@ static C_TLS struct stat C_statbuf;
#define C_close(fd) C_fix(close(C_unfix(fd)))
#define C_umask(m) C_fix(umask(C_unfix(m)))
-#define C_lstat(fn) C_fix(lstat((char *)C_data_pointer(fn), &C_statbuf))
+#define C_u_i_lstat(fn) C_fix(lstat((char *)C_data_pointer(fn), &C_statbuf))
#define C_u_i_execvp(f,a) C_fix(execvp(C_data_pointer(f), (char *const *)C_c_pointer_vector_or_null(a)))
#define C_u_i_execve(f,a,e) C_fix(execve(C_data_pointer(f), (char *const *)C_c_pointer_vector_or_null(a), (char *const *)C_c_pointer_vector_or_null(e)))
diff --git a/posixwin.scm b/posixwin.scm
index 704b2689..fecfc4e4 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -199,7 +199,7 @@ readdir(DIR * dir)
#define C_getenventry(i) environ[ i ]
-#define C_lstat(fn) C_stat(fn)
+#define C_u_i_lstat(fn) C_u_i_stat(fn)
#define C_u_i_execvp(f,a) C_fix(execvp(C_data_pointer(f), (const char *const *)C_c_pointer_vector_or_null(a)))
#define C_u_i_execve(f,a,e) C_fix(execve(C_data_pointer(f), (const char *const *)C_c_pointer_vector_or_null(a), (const char *const *)C_c_pointer_vector_or_null(e)))
@@ -577,7 +577,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
/* Only stat if needed */
if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {
- if (stat(filename, &sb) == -1) return -1;
+ if (C_stat(filename, &sb) == -1) return -1;
}
if (atime == C_SCHEME_FALSE) {
diff --git a/runtime.c b/runtime.c
index 93460208..12471fdf 100644
--- a/runtime.c
+++ b/runtime.c
@@ -28,7 +28,6 @@
#include "chicken.h"
#include <assert.h>
-#include <errno.h>
#include <float.h>
#include <signal.h>
#include <sys/stat.h>
@@ -12580,7 +12579,7 @@ C_i_file_exists_p(C_word name, C_word file, C_word dir)
struct stat buf;
int res;
- res = stat(C_c_string(name), &buf);
+ res = C_stat(C_c_string(name), &buf);
if(res != 0) {
switch(errno) {
diff --git a/tests/file-access-tests.scm b/tests/file-access-tests.scm
new file mode 100644
index 00000000..79682f2d
--- /dev/null
+++ b/tests/file-access-tests.scm
@@ -0,0 +1,65 @@
+;;
+;; Tests for file and directory access.
+;;
+;; These may seem silly, but some of them actually fail on MinGW without help.
+;;
+
+(define / (car (command-line-arguments)))
+(define // (string-append / /))
+(define /// (string-append / / /))
+
+(assert (not (file-exists? "")))
+(assert (not (directory-exists? "")))
+
+(assert (file-exists? /))
+(assert (file-exists? //))
+(assert (file-exists? ///))
+
+(assert (directory-exists? /))
+(assert (directory-exists? //))
+(assert (directory-exists? ///))
+
+(assert (file-exists? "."))
+(assert (file-exists? ".."))
+
+(assert (directory-exists? "."))
+(assert (directory-exists? ".."))
+
+(assert (file-exists? (string-append "." /)))
+(assert (file-exists? (string-append "." //)))
+(assert (file-exists? (string-append "." ///)))
+
+(assert (file-exists? (string-append ".." /)))
+(assert (file-exists? (string-append ".." //)))
+(assert (file-exists? (string-append ".." ///)))
+
+(assert (file-exists? (string-append ".." / "tests")))
+(assert (file-exists? (string-append ".." / "tests" /)))
+(assert (file-exists? (string-append ".." / "tests" //)))
+(assert (file-exists? (string-append ".." / "tests" ///)))
+
+(assert (directory-exists? (string-append "." /)))
+(assert (directory-exists? (string-append "." //)))
+(assert (directory-exists? (string-append "." ///)))
+
+(assert (directory-exists? (string-append ".." /)))
+(assert (directory-exists? (string-append ".." //)))
+(assert (directory-exists? (string-append ".." ///)))
+
+(assert (directory-exists? (string-append ".." / "tests")))
+(assert (directory-exists? (string-append ".." / "tests" /)))
+(assert (directory-exists? (string-append ".." / "tests" //)))
+(assert (directory-exists? (string-append ".." / "tests" ///)))
+
+(assert (file-exists? (program-name)))
+(assert (not (directory-exists? (program-name))))
+
+(assert (not (file-exists? (string-append (program-name) /))))
+(assert (not (file-exists? (string-append (program-name) //))))
+(assert (not (file-exists? (string-append (program-name) ///))))
+
+(assert (not (directory-exists? (string-append (program-name) /))))
+(assert (not (directory-exists? (string-append (program-name) //))))
+(assert (not (directory-exists? (string-append (program-name) ///))))
+
+(print "All tests passed for slash: " /)
diff --git a/tests/posix-tests.scm b/tests/posix-tests.scm
index 381b7ff7..706a8dff 100644
--- a/tests/posix-tests.scm
+++ b/tests/posix-tests.scm
@@ -39,7 +39,8 @@
(receive (in out pid)
(process "../csi" '("-n" "-I" ".." "-e"
"(write 'err (current-error-port)) (write 'ok)"))
- (assert (equal? 'ok (read in))))
+ (assert (equal? 'ok (read in)))
+ (newline (current-error-port)))
(receive (in out pid err)
(process* "../csi" '("-n" "-I" ".." "-e"
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 2d25a98e..4f558326 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -460,6 +460,12 @@ if errorlevel 1 exit /b 1
a.out
if errorlevel 1 exit /b 1
+echo ======================================== file access tests ...
+%interpret% -s file-access-tests.scm /
+if errorlevel 1 exit /b 1
+%interpret% -s file-access-tests.scm \
+if errorlevel 1 exit /b 1
+
echo ======================================== find-files tests ...
%interpret% -bnq test-find-files.scm
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 752e6b74..05748810 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -363,6 +363,14 @@ echo "======================================== posix tests ..."
$compile posix-tests.scm
./a.out
+echo "======================================== file access tests ..."
+if test -n "$MSYSTEM"; then
+ $interpret -s file-access-tests.scm //
+ $interpret -s file-access-tests.scm \\
+else
+ $interpret -s file-access-tests.scm /
+fi
+
echo "======================================== find-files tests ..."
$interpret -bnq test-find-files.scm
Trap