|
From: David L. <lic...@us...> - 2011-08-11 20:07:57
|
The branch "master" has been updated in SBCL:
via 6caf3ed5713773cb423f46bf40a29f2438c97c78 (commit)
from 7254da92a1ba1bf8bc5a2e78a29d993f272d526e (commit)
- Log -----------------------------------------------------------------
commit 6caf3ed5713773cb423f46bf40a29f2438c97c78
Author: David Lichteblau <da...@li...>
Date: Thu Aug 11 21:08:09 2011 +0200
Fix QUERY-FILE-SYSTEM for Windows UNC and device file names
Thanks to Anton Kovalenko.
---
package-data-list.lisp-expr | 7 +++++
src/code/filesys.lisp | 16 ++++++++++++
src/code/win32.lisp | 57 +++++++++++++++++++++++++++++++++++++++++++
src/runtime/win32-os.c | 4 +++
4 files changed, 84 insertions(+), 0 deletions(-)
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 112d88e..0bf8ed8 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2836,13 +2836,20 @@ SBCL itself"
:use ("CL" "SB!ALIEN" "SB!EXT" "SB!INT" "SB!SYS")
:export ("BOOL"
"CLOSE-HANDLE"
+ "CREATE-FILE"
"CREATE-FILE-MAPPING"
"DWORD"
"FD-CLEAR-INPUT"
"FD-LISTEN"
+ "FILE-CREATE-ALWAYS"
+ "FILE-CREATE-NEW"
+ "FILE-OPEN-ALWAYS"
+ "FILE-OPEN-EXISTING"
+ "FILE-TRUNCATE-EXISTING"
"FLUSH-CONSOLE-INPUT-BUFFER"
"FLUSH-VIEW-OF-FILE"
"FORMAT-MESSAGE"
+ "GET-FILE-ATTRIBUTES"
"GET-LAST-ERROR"
"GET-OSFHANDLE"
"GET-VERSION-EX"
diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index c8a3999..8817dcf 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -296,6 +296,22 @@
(sb!unix:unix-stat filename)
(declare (ignore ino nlink gid rdev size atime
#!+win32 uid))
+ #!+win32
+ ;; On win32, stat regards UNC pathnames and device names as
+ ;; nonexisting, so we check once more with the native API.
+ (unless existsp
+ (setf existsp
+ (let ((handle (sb!win32:create-file
+ filename 0 0 nil
+ sb!win32:file-open-existing
+ 0 0)))
+ (when (/= -1 handle)
+ (setf mode
+ (or mode
+ (if (logbitp 4
+ (sb!win32:get-file-attributes filename))
+ sb!unix:s-ifdir 0)))
+ (progn (sb!win32:close-handle handle) t)))))
(if existsp
(case query-for
(:existence (nth-value
diff --git a/src/code/win32.lisp b/src/code/win32.lisp
index 7481fc5..25b00ad 100644
--- a/src/code/win32.lisp
+++ b/src/code/win32.lisp
@@ -665,5 +665,62 @@ UNIX epoch: January 1st 1970."
(address (* t))
(length dword))
+;; Constants for CreateFile `disposition'.
+(defconstant file-create-new 1)
+(defconstant file-create-always 2)
+(defconstant file-open-existing 3)
+(defconstant file-open-always 4)
+(defconstant file-truncate-existing 5)
+
+;; access rights
+(defconstant access-generic-read #x80000000)
+(defconstant access-generic-write #x40000000)
+(defconstant access-generic-execute #x20000000)
+(defconstant access-generic-all #x10000000)
+(defconstant access-file-append-data #x4)
+
+;; share modes
+(defconstant file-share-delete #x04)
+(defconstant file-share-read #x01)
+(defconstant file-share-write #x02)
+
+;; CreateFile (the real file-opening workhorse)
+(define-alien-routine (#!+sb-unicode "CreateFileW"
+ #!-sb-unicode "CreateFileA"
+ create-file)
+ handle
+ (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2))
+ (desired-access dword)
+ (share-mode dword)
+ (security-attributes (* t))
+ (creation-disposition dword)
+ (flags-and-attributes dword)
+ (template-file handle))
+
+(defconstant file-attribute-readonly #x1)
+(defconstant file-attribute-hidden #x2)
+(defconstant file-attribute-system #x4)
+(defconstant file-attribute-directory #x10)
+(defconstant file-attribute-archive #x20)
+(defconstant file-attribute-device #x40)
+(defconstant file-attribute-normal #x80)
+(defconstant file-attribute-temporary #x100)
+(defconstant file-attribute-sparse #x200)
+(defconstant file-attribute-reparse-point #x400)
+(defconstant file-attribute-reparse-compressed #x800)
+(defconstant file-attribute-reparse-offline #x1000)
+(defconstant file-attribute-not-content-indexed #x2000)
+(defconstant file-attribute-encrypted #x4000)
+
+(defconstant file-flag-overlapped #x40000000)
+
+;; GetFileAttribute is like a tiny subset of fstat(),
+;; enough to distinguish directories from anything else.
+(define-alien-routine (#!+sb-unicode "GetFileAttributesW"
+ #!-sb-unicode "GetFileAttributesA"
+ get-file-attributes)
+ dword
+ (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
+
(define-alien-routine ("CloseHandle" close-handle) bool
(handle handle))
diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c
index 406f011..6be2b12 100644
--- a/src/runtime/win32-os.c
+++ b/src/runtime/win32-os.c
@@ -579,9 +579,11 @@ void scratch(void)
#ifndef LISP_FEATURE_SB_UNICODE
CreateDirectoryA(0,0);
CreateFileMappingA(0,0,0,0,0,0);
+ CreateFileA(0,0,0,0,0,0,0);
GetComputerNameA(0, 0);
GetCurrentDirectoryA(0,0);
GetEnvironmentVariableA(0, 0, 0);
+ GetFileAttributesA(0);
GetVersionExA(0);
MoveFileA(0,0);
SHGetFolderPathA(0, 0, 0, 0, 0);
@@ -590,10 +592,12 @@ void scratch(void)
#else
CreateDirectoryW(0,0);
CreateFileMappingW(0,0,0,0,0,0);
+ CreateFileW(0,0,0,0,0,0,0);
FormatMessageW(0, 0, 0, 0, 0, 0, 0);
GetComputerNameW(0, 0);
GetCurrentDirectoryW(0,0);
GetEnvironmentVariableW(0, 0, 0);
+ GetFileAttributesW(0);
GetVersionExW(0);
MoveFileW(0,0);
SHGetFolderPathW(0, 0, 0, 0, 0);
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|