;;; but groveling HANDLE makes it unsigned, which currently breaks the
;;; build. --NS 2006-06-18
(define-alien-type handle int-ptr)
+
+(define-alien-type lispbool (boolean 32))
+
(define-alien-type system-string
#!-sb-unicode c-string
#!+sb-unicode (c-string :external-format :ucs-2))
(defun handle-listen (handle)
(with-alien ((avail dword)
(buf (array char #.input-record-size)))
+ (when
+ ;; Make use of the fact that console handles are technically no
+ ;; real handles, and unlike those, have these bits set:
+ (= 3 (logand 3 handle))
+ (return-from handle-listen
+ (alien-funcall (extern-alien "win32_tty_listen"
+ (function boolean handle))
+ handle)))
(unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil))
(return-from handle-listen (plusp avail)))
;;;; System Functions
-;;; Sleep for MILLISECONDS milliseconds.
+#!-sb-thread
(define-alien-routine ("Sleep@4" millisleep) void
(milliseconds dword))
+#!+sb-thread
+(defun sb!unix:nanosleep (sec nsec)
+ (let ((*allow-with-interrupts* *interrupts-enabled*))
+ (without-interrupts
+ (let ((timer (sb!impl::os-create-wtimer)))
+ (sb!impl::os-set-wtimer timer sec nsec)
+ (unwind-protect
+ (do () ((with-local-interrupts
+ (zerop (sb!impl::os-wait-for-wtimer timer)))))
+ (sb!impl::os-close-wtimer timer))))))
+
#!+sb-unicode
(progn
(defvar *ansi-codepage* nil)
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))
(setf aname (make-system-buffer length))
(alien-funcall afunc aname (addr length))))
(cast-and-free aname))))
+
+(define-alien-routine ("SetFilePointerEx" set-file-pointer-ex) lispbool
+ (handle handle)
+ (offset long-long)
+ (new-position long-long :out)
+ (whence dword))
+
+;; 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)
+(defconstant file-flag-sequential-scan #x8000000)
+
+;; 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))
+
+(define-alien-routine ("_open_osfhandle" open-osfhandle)
+ int
+ (handle handle)
+ (flags int))
+
+;; Intended to be an imitation of sb!unix:unix-open based on
+;; CreateFile, as complete as possibly.
+;; FILE_FLAG_OVERLAPPED is a must for decent I/O.
+
+(defun unixlike-open (path flags mode &optional revertable)
+ (declare (type sb!unix:unix-pathname path)
+ (type fixnum flags)
+ (type sb!unix:unix-file-mode mode)
+ (ignorable mode))
+ (let* ((disposition-flags
+ (logior
+ (if (zerop (logand sb!unix:o_creat flags)) 0 #b100)
+ (if (zerop (logand sb!unix:o_excl flags)) 0 #b010)
+ (if (zerop (logand sb!unix:o_trunc flags)) 0 #b001)))
+ (create-disposition
+ ;; there are 8 combinations of creat|excl|trunc, some of
+ ;; them are equivalent. Case stmt below maps them to 5
+ ;; dispositions (see CreateFile manual).
+ (case disposition-flags
+ ((#b110 #b111) file-create-new)
+ ((#b001 #b011) file-truncate-existing)
+ ((#b000 #b010) file-open-existing)
+ (#b100 file-open-always)
+ (#b101 file-create-always))))
+ (let ((handle
+ (create-file path
+ (logior
+ (if revertable #x10000 0)
+ (if (plusp (logand sb!unix:o_append flags))
+ access-file-append-data
+ 0)
+ (ecase (logand 3 flags)
+ (0 FILE_GENERIC_READ)
+ (1 FILE_GENERIC_WRITE)
+ ((2 3) (logior FILE_GENERIC_READ
+ FILE_GENERIC_WRITE))))
+ (logior FILE_SHARE_READ
+ FILE_SHARE_WRITE)
+ nil
+ create-disposition
+ (logior
+ file-attribute-normal
+ file-flag-overlapped
+ file-flag-sequential-scan)
+ 0)))
+ (if (eql handle invalid-handle)
+ (values nil
+ (let ((error-code (get-last-error)))
+ (case error-code
+ (#.error_file_not_found
+ sb!unix:enoent)
+ ((#.error_already_exists #.error_file_exists)
+ sb!unix:eexist)
+ (otherwise (- error-code)))))
+ (progn
+ ;; FIXME: seeking to the end is not enough for real APPEND
+ ;; semantics, but it's better than nothing.
+ ;; -- AK
+ ;;
+ ;; On the other hand, the CL spec implies the "better than
+ ;; nothing" seek-once semantics implemented here, and our
+ ;; POSIX backend is incorrect in implementing :APPEND as
+ ;; O_APPEND. Other CL implementations get this right across
+ ;; platforms.
+ ;;
+ ;; Of course, it would be nice if we had :IF-EXISTS
+ ;; :ATOMICALLY-APPEND separately as an extension, and in
+ ;; that case, we will have to worry about supporting it
+ ;; here after all.
+ ;;
+ ;; I've tested this only very briefly (on XP and Windows 7),
+ ;; but my impression is that WriteFile (without documenting
+ ;; it?) is like ZwWriteFile, i.e. if we pass in -1 as the
+ ;; offset in our overlapped structure, WriteFile seeks to the
+ ;; end for us. Should we depend on that? How do we communicate
+ ;; our desire to do so to the runtime?
+ ;; -- DFL
+ ;;
+ (set-file-pointer-ex handle 0 (if (plusp (logand sb!unix::o_append flags)) 2 0))
+ (let ((fd (open-osfhandle handle (logior sb!unix::o_binary flags))))
+ (if (minusp fd)
+ (values nil (sb!unix::get-errno))
+ (values fd 0))))))))
+
+(define-alien-routine ("closesocket" close-socket) int (handle handle))
+(define-alien-routine ("shutdown" shutdown-socket) int (handle handle)
+ (how int))
+
+(define-alien-routine ("DuplicateHandle" duplicate-handle) lispbool
+ (from-process handle)
+ (from-handle handle)
+ (to-process handle)
+ (to-handle handle :out)
+ (access dword)
+ (inheritp lispbool)
+ (options dword))
+
+(defconstant +handle-flag-inherit+ 1)
+(defconstant +handle-flag-protect-from-close+ 2)
+
+(define-alien-routine ("SetHandleInformation" set-handle-information) lispbool
+ (handle handle)
+ (mask dword)
+ (flags dword))
+
+(define-alien-routine ("GetHandleInformation" get-handle-information) lispbool
+ (handle handle)
+ (flags dword :out))
+
+(define-alien-routine getsockopt int
+ (handle handle)
+ (level int)
+ (opname int)
+ (dataword int-ptr :in-out)
+ (socklen int :in-out))
+
+(defconstant sol_socket #xFFFF)
+(defconstant so_type #x1008)
+
+(defun socket-handle-p (handle)
+ (zerop (getsockopt handle sol_socket so_type 0 (alien-size int :bytes))))
+
+(defconstant ebadf 9)
+
+;;; For sockets, CloseHandle first and closesocket() afterwards is
+;;; legal: winsock tracks its handles separately (that's why we have
+;;; the problem with simple _close in the first place).
+;;;
+;;; ...Seems to be the problem on some OSes, though. We could
+;;; duplicate a handle and attempt close-socket on a duplicated one,
+;;; but it also have some problems...
+;;;
+;;; For now, we protect socket handle from close with SetHandleInformation,
+;;; then call CRT _close() that fails to close a handle but _gets rid of fd_,
+;;; and then we close a handle ourserves.
+
+(defun unixlike-close (fd)
+ (let ((handle (get-osfhandle fd)))
+ (flet ((close-protection (enable)
+ (set-handle-information handle 2 (if enable 2 0))))
+ (if (= handle invalid-handle)
+ (values nil ebadf)
+ (progn
+ (when (and (socket-handle-p handle) (close-protection t))
+ (shutdown-socket handle 2)
+ (alien-funcall (extern-alien "_dup2" (function int int int)) 0 fd)
+ (close-protection nil)
+ (close-socket handle))
+ (sb!unix::void-syscall ("close" int) fd))))))
projects / sbcl.git / blobdiff