From: David Lichteblau <david@lichteblau.com>
Date: Thu, 11 Aug 2011 19:08:09 +0000 (+0200)
Subject: Fix QUERY-FILE-SYSTEM for Windows UNC and device file names
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6caf3ed5713773cb423f46bf40a29f2438c97c78;p=sbcl.git

Fix QUERY-FILE-SYSTEM for Windows UNC and device file names

Thanks to Anton Kovalenko.
---

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);