run-program: proper handling of :if-input-does-not-exist NIL.

[sbcl.git] / src / code / win32.lisp

diff --git a/src/code/win32.lisp b/src/code/win32.lisp
index fb3d5c1..25b00ad 100644 (file)
--- a/src/code/win32.lisp
+++ b/src/code/win32.lisp
@@ -118,7 +118,7 @@
 
     (unless (zerop (peek-console-input handle
                                        (cast buf (* t))
-                                       input-record-size (addr avail)))
+                                       1 (addr avail)))
       (return-from handle-listen (plusp avail)))
 
     ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
@@ -432,14 +432,16 @@
             err-code
             (get-last-error-message err-code))))
 
-(defun get-folder-pathname (csidl)
+(defun get-folder-namestring (csidl)
   "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
   (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
     (syscall (("SHGetFolderPath" 20 t) int handle int handle dword (* char))
-             (parse-native-namestring
-               (concatenate 'string (cast-and-free apath) "\\"))
+             (concatenate 'string (cast-and-free apath) "\\")
              0 csidl 0 0 apath)))
 
+(defun get-folder-pathname (csidl)
+  (parse-native-namestring (get-folder-namestring csidl)))
+
 (defun sb!unix:posix-getcwd ()
   (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
     (with-sysfun (afunc ("GetCurrentDirectory" 8 t) dword dword (* char))
@@ -564,7 +566,7 @@
 #!-sb-fluid
 (declaim (inline get-time-of-day))
 (defun get-time-of-day ()
-  "Return the number of seconds and microseconds since the beginning og the
+  "Return the number of seconds and microseconds since the beginning of the
 UNIX epoch: January 1st 1970."
   (with-alien ((system-time filetime))
     (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
@@ -635,3 +637,90 @@ UNIX epoch: January 1st 1970."
           (setf aname (make-system-buffer length))
           (alien-funcall afunc aname (addr length))))
       (cast-and-free aname))))
+
+;; File mapping support routines
+(define-alien-routine (#!+sb-unicode "CreateFileMappingW"
+                       #!-sb-unicode "CreateFileMappingA"
+                       create-file-mapping)
+    handle
+  (handle handle)
+  (security-attributes (* t))
+  (protection dword)
+  (maximum-size-high dword)
+  (maximum-size-low dword)
+  (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
+
+(define-alien-routine ("MapViewOfFile" map-view-of-file)
+    system-area-pointer
+  (file-mapping handle)
+  (desired-access dword)
+  (offset-high dword)
+  (offset-low dword)
+  (size dword))
+
+(define-alien-routine ("UnmapViewOfFile" unmap-view-of-file) bool
+  (address (* t)))
+
+(define-alien-routine ("FlushViewOfFile" flush-view-of-file) bool
+  (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))