X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fwin32.lisp;h=2dd8c8d66a0b4b873e9d2cf1a45dc2ea01575aca;hb=eac461c1f1ca91cfe282c779291d582ed6b336cb;hp=7481fc57c830420ad28515447ff6714617fcb434;hpb=ad4b18f5d843d91cc48c9b6cc936a6c7be5fce27;p=sbcl.git diff --git a/src/code/win32.lisp b/src/code/win32.lisp index 7481fc5..2dd8c8d 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -21,6 +21,9 @@ ;;; 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)) @@ -113,6 +116,14 @@ (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))) @@ -154,10 +165,21 @@ ;;;; 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) @@ -638,6 +660,12 @@ UNIX epoch: January 1st 1970." (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" @@ -665,5 +693,218 @@ 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) +(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))))))