X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32.lisp;h=a01ac3627aa47b05173c78fd6137df6c1e139c0e;hb=1b6d885eaf7872b41947e0ea0da134cceee4cc0f;hp=944d2065cf1596f64acfc4b360d066ea41d74e81;hpb=7572e0506af331534e6f97b027d56e8bea09410c;p=sbcl.git diff --git a/src/code/win32.lisp b/src/code/win32.lisp index 944d206..a01ac36 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -38,7 +38,7 @@ ;;; Retrieve the calling thread's last-error code value. The ;;; last-error code is maintained on a per-thread basis. -(define-alien-routine ("GetLastError@0" get-last-error) dword) +(define-alien-routine ("GetLastError" get-last-error) dword) ;;; Flag constants for FORMAT-MESSAGE. (defconstant format-message-from-system #x1000) @@ -46,7 +46,7 @@ ;;; Format an error message based on a lookup table. See MSDN for the ;;; full meaning of the all options---most are not used when getting ;;; system error codes. -(define-alien-routine ("FormatMessageA@28" format-message) dword +(define-alien-routine ("FormatMessageA" format-message) dword (flags dword) (source (* t)) (message-id dword) @@ -57,14 +57,42 @@ ;;;; File Handles +;;; Historically, SBCL on Windows used CRT (lowio) file descriptors, +;;; unlike other Lisps. They really help to minimize required effort +;;; for porting Unix-specific software, at least to the level that it +;;; mostly works most of the time. +;;; +;;; Alastair Bridgewater recommended to switch away from CRT +;;; descriptors, and Anton Kovalenko thinks it's the time to heed his +;;; advice. I see that SBCL for Windows needs much more effort in the +;;; area of OS IO abstractions and the like; using or leaving lowio +;;; FDs doesn't change the big picture so much. +;;; +;;; Lowio layer, in exchange for `semi-automatic almost-portability', +;;; brings some significant problems, which a grown-up cross-platform +;;; CL implementation shouldn't have. Therefore, as its benefits +;;; become negligible, it's a good reason to throw it away. +;;; +;;; -- comment from AK's branch + +;;; For a few more releases, let's preserve old functions (now +;;; implemented as identity) for user code which might have had to peek +;;; into our internals in past versions when we hadn't been using +;;; handles yet. -- DFL, 2012 +(defun get-osfhandle (fd) fd) +(defun open-osfhandle (handle flags) (declare (ignore flags)) handle) + ;;; Get the operating system handle for a C file descriptor. Returns ;;; INVALID-HANDLE on failure. -(define-alien-routine ("_get_osfhandle" get-osfhandle) handle +(define-alien-routine ("_get_osfhandle" real-get-osfhandle) handle + (fd int)) + +(define-alien-routine ("_close" real-crt-close) int (fd int)) ;;; Read data from a file handle into a buffer. This may be used ;;; synchronously or with "overlapped" (asynchronous) I/O. -(define-alien-routine ("ReadFile@20" read-file) bool +(define-alien-routine ("ReadFile" read-file) bool (file handle) (buffer (* t)) (bytes-to-read dword) @@ -73,7 +101,7 @@ ;;; Write data from a buffer to a file handle. This may be used ;;; synchronously or with "overlapped" (asynchronous) I/O. -(define-alien-routine ("WriteFile@20" write-file) bool +(define-alien-routine ("WriteFile" write-file) bool (file handle) (buffer (* t)) (bytes-to-write dword) @@ -84,7 +112,7 @@ ;;; removing it from the pipe. BUFFER, BYTES-READ, BYTES-AVAIL, and ;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read. ;;; Return TRUE on success, FALSE on failure. -(define-alien-routine ("PeekNamedPipe@24" peek-named-pipe) bool +(define-alien-routine ("PeekNamedPipe" peek-named-pipe) bool (pipe handle) (buffer (* t)) (buffer-size dword) @@ -95,18 +123,21 @@ ;;; Flush the console input buffer if HANDLE is a console handle. ;;; Returns true on success, false if the handle does not refer to a ;;; console. -(define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool +(define-alien-routine ("FlushConsoleInputBuffer" flush-console-input-buffer) bool (handle handle)) ;;; Read data from the console input buffer without removing it, ;;; without blocking. Buffer should be large enough for LENGTH * ;;; INPUT-RECORD-SIZE bytes. -(define-alien-routine ("PeekConsoleInputA@16" peek-console-input) bool +(define-alien-routine ("PeekConsoleInputA" peek-console-input) bool (handle handle) (buffer (* t)) (length dword) (nevents (* dword))) +(define-alien-routine ("socket_input_available" socket-input-available) int + (socket handle)) + ;;; Listen for input on a Windows file handle. Unlike UNIX, there ;;; isn't a unified interface to do this---we have to know what sort ;;; of handle we have. Of course, there's no way to actually @@ -116,16 +147,19 @@ (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))) - - (unless (zerop (peek-console-input handle - (cast buf (* t)) - 1 (addr avail))) - (return-from handle-listen (plusp avail))) - - ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case - ;; HANDLE is a socket. + (let ((res (socket-input-available handle))) + (unless (zerop res) + (return-from handle-listen (= res 1)))) t)) ;;; Listen for input on a C runtime file handle. Returns true if @@ -158,7 +192,7 @@ ;;;; System Functions #!-sb-thread -(define-alien-routine ("Sleep@4" millisleep) void +(define-alien-routine ("Sleep" millisleep) void (milliseconds dword)) #!+sb-thread @@ -172,6 +206,10 @@ (zerop (sb!impl::os-wait-for-wtimer timer))))) (sb!impl::os-close-wtimer timer)))))) +(define-alien-routine ("win32_wait_object_or_signal" wait-object-or-signal) + (signed 16) + (handle handle)) + #!+sb-unicode (progn (defvar *ansi-codepage* nil) @@ -340,7 +378,7 @@ (defun ansi-codepage () (or *ansi-codepage* (setq *ansi-codepage* - (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT))) + (gethash (alien-funcall (extern-alien "GetACP" (function UINT))) *codepage-to-external-format* :latin-1)))) @@ -348,7 +386,7 @@ (defun oem-codepage () (or *oem-codepage* (setq *oem-codepage* - (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT))) + (gethash (alien-funcall (extern-alien "GetOEMCP" (function UINT))) *codepage-to-external-format* :latin-1))))) @@ -356,7 +394,7 @@ (declaim (ftype (function () keyword) console-input-codepage)) (defun console-input-codepage () (or #!+sb-unicode - (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT))) + (gethash (alien-funcall (extern-alien "GetConsoleCP" (function UINT))) *codepage-to-external-format*) :latin-1)) @@ -365,11 +403,11 @@ (defun console-output-codepage () (or #!+sb-unicode (gethash (alien-funcall - (extern-alien "GetConsoleOutputCP@0" (function UINT))) + (extern-alien "GetConsoleOutputCP" (function UINT))) *codepage-to-external-format*) :latin-1)) -(define-alien-routine ("LocalFree@4" local-free) void +(define-alien-routine ("LocalFree" local-free) void (lptr (* t))) (defmacro cast-and-free (value &key (type 'system-string) @@ -382,15 +420,21 @@ `(let ((,name (etypecase ,description (string ,description) - (cons (destructuring-bind (s &optional (l 0) c) ,description - (format nil "~A~A~A" s - (if c #!-sb-unicode "A@" #!+sb-unicode "W@" "@") - l)))))) + (cons (destructuring-bind (s &optional c) ,description + (format nil "~A~A" s + (if c #!-sb-unicode "A" #!+sb-unicode "W" ""))))))) ,@body))) (defmacro make-system-buffer (x) `(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x)) +(define-alien-type pathname-buffer + (array char #.(ash (1+ max_path) #!+sb-unicode 1 #!-sb-unicode 0))) + +(define-alien-type long-pathname-buffer + #!+sb-unicode (array char 65536) + #!-sb-unicode pathname-buffer) + ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other ;;; macros in this file, are only used in this file, and could be ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN. @@ -432,7 +476,7 @@ (defun get-last-error-message (err) "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp" (with-alien ((amsg (* char))) - (syscall (("FormatMessage" 28 t) + (syscall (("FormatMessage" t) dword dword dword dword dword (* (* char)) dword dword) (cast-and-free amsg :free-function local-free) (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM) @@ -449,7 +493,7 @@ (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)) + (syscall (("SHGetFolderPath" t) int handle int handle dword (* char)) (concatenate 'string (cast-and-free apath) "\\") 0 csidl 0 0 apath))) @@ -458,7 +502,7 @@ (defun sb!unix:posix-getcwd () (with-alien ((apath (* char) (make-system-buffer (1+ max_path)))) - (with-sysfun (afunc ("GetCurrentDirectory" 8 t) dword dword (* char)) + (with-sysfun (afunc ("GetCurrentDirectory" t) dword dword (* char)) (let ((ret (alien-funcall afunc (1+ max_path) apath))) (when (zerop ret) (win32-error "GetCurrentDirectory")) @@ -472,16 +516,16 @@ (declare (type sb!unix:unix-pathname name) (type sb!unix:unix-file-mode mode) (ignore mode)) - (void-syscall* (("CreateDirectory" 8 t) system-string dword) name 0)) + (void-syscall* (("CreateDirectory" t) system-string dword) name 0)) (defun sb!unix:unix-rename (name1 name2) (declare (type sb!unix:unix-pathname name1 name2)) - (void-syscall* (("MoveFile" 8 t) system-string system-string) name1 name2)) + (void-syscall* (("MoveFile" t) system-string system-string) name1 name2)) (defun sb!unix::posix-getenv (name) (declare (type simple-string name)) (with-alien ((aenv (* char) (make-system-buffer default-environment-length))) - (with-sysfun (afunc ("GetEnvironmentVariable" 12 t) + (with-sysfun (afunc ("GetEnvironmentVariable" t) dword system-string (* char) dword) (let ((ret (alien-funcall afunc name aenv default-environment-length))) (when (> ret default-environment-length) @@ -498,7 +542,7 @@ ;; ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getcurrentprocess.asp (declaim (inline get-current-process)) -(define-alien-routine ("GetCurrentProcess@0" get-current-process) handle) +(define-alien-routine ("GetCurrentProcess" get-current-process) handle) ;;;; Process time information @@ -518,7 +562,7 @@ (,exit-time filetime) (,kernel-time filetime) (,user-time filetime)) - (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime) + (syscall* (("GetProcessTimes") handle (* filetime) (* filetime) (* filetime) (* filetime)) (progn ,@forms) (get-current-process) @@ -537,7 +581,7 @@ epoch (get-internal-real-time))) (defun get-internal-real-time () (- (with-alien ((system-time filetime)) - (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime)) + (syscall (("GetSystemTimeAsFileTime") void (* filetime)) (values (floor system-time 100ns-per-internal-time-unit)) (addr system-time))) epoch))) @@ -583,7 +627,7 @@ "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)) + (syscall (("GetSystemTimeAsFileTime") void (* filetime)) (multiple-value-bind (sec 100ns) (floor (- system-time +unix-epoch-filetime+) (* 100ns-per-internal-time-unit @@ -598,7 +642,7 @@ UNIX epoch: January 1st 1970." ;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp (defun setenv (name value) (declare (type simple-string name value)) - (void-syscall* (("SetEnvironmentVariable" 8 t) system-string system-string) + (void-syscall* (("SetEnvironmentVariable" t) system-string system-string) name value)) (defmacro c-sizeof (s) @@ -624,7 +668,7 @@ UNIX epoch: January 1st 1970." (defun get-version-ex () (with-alien ((info (struct OSVERSIONINFO))) (setf (slot info 'dwOSVersionInfoSize) (c-sizeof (struct OSVERSIONINFO))) - (syscall* (("GetVersionEx" 4 t) (* (struct OSVERSIONINFO))) + (syscall* (("GetVersionEx" t) (* (struct OSVERSIONINFO))) (values (slot info 'dwMajorVersion) (slot info 'dwMinorVersion) (slot info 'dwBuildNumber) @@ -642,7 +686,7 @@ UNIX epoch: January 1st 1970." (defun get-computer-name () (with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH))) (length dword (1+ MAX_COMPUTERNAME_LENGTH))) - (with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword)) + (with-sysfun (afunc ("GetComputerName" t) bool (* char) (* dword)) (when (zerop (alien-funcall afunc aname (addr length))) (let ((err (get-last-error))) (unless (= err ERROR_BUFFER_OVERFLOW) @@ -658,6 +702,13 @@ UNIX epoch: January 1st 1970." (new-position long-long :out) (whence dword)) +(defun lseeki64 (handle offset whence) + (multiple-value-bind (moved to-place) + (set-file-pointer-ex handle offset whence) + (if moved + (values to-place 0) + (values -1 (- (get-last-error)))))) + ;; File mapping support routines (define-alien-routine (#!+sb-unicode "CreateFileMappingW" #!-sb-unicode "CreateFileMappingA" @@ -735,6 +786,19 @@ UNIX epoch: January 1st 1970." (defconstant file-flag-overlapped #x40000000) (defconstant file-flag-sequential-scan #x8000000) +;; Possible results of GetFileType. +(defconstant file-type-disk 1) +(defconstant file-type-char 2) +(defconstant file-type-pipe 3) +(defconstant file-type-remote 4) +(defconstant file-type-unknown 0) + +(defconstant invalid-file-attributes (mod -1 (ash 1 32))) + +;;;; File Type Introspection by handle +(define-alien-routine ("GetFileType" get-file-type) dword + (handle handle)) + ;; GetFileAttribute is like a tiny subset of fstat(), ;; enough to distinguish directories from anything else. (define-alien-routine (#!+sb-unicode "GetFileAttributesW" @@ -746,7 +810,7 @@ UNIX epoch: January 1st 1970." (define-alien-routine ("CloseHandle" close-handle) bool (handle handle)) -(define-alien-routine ("_open_osfhandle" open-osfhandle) +(define-alien-routine ("_open_osfhandle" real-open-osfhandle) int (handle handle) (flags int)) @@ -830,10 +894,7 @@ UNIX epoch: January 1st 1970." ;; -- 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)))))))) + (values handle 0)))))) (define-alien-routine ("closesocket" close-socket) int (handle handle)) (define-alien-routine ("shutdown" shutdown-socket) int (handle handle) @@ -882,21 +943,82 @@ UNIX epoch: January 1st 1970." ;;; ...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)))))) + (if (or (zerop (close-socket fd)) + (close-handle fd)) + t (values nil ebadf))) + +(defconstant +std-input-handle+ -10) +(defconstant +std-output-handle+ -11) +(defconstant +std-error-handle+ -12) + +(defun get-std-handle-or-null (identity) + (let ((handle (alien-funcall + (extern-alien "GetStdHandle" (function handle dword)) + (logand (1- (ash 1 (alien-size dword))) identity)))) + (and (/= handle invalid-handle) + (not (zerop handle)) + handle))) + +(defun get-std-handles () + (values (get-std-handle-or-null +std-input-handle+) + (get-std-handle-or-null +std-output-handle+) + (get-std-handle-or-null +std-error-handle+))) + +(defconstant +duplicate-same-access+ 2) + +(defun duplicate-and-unwrap-fd (fd &key inheritp) + (let ((me (get-current-process))) + (multiple-value-bind (duplicated handle) + (duplicate-handle me (real-get-osfhandle fd) + me 0 inheritp +duplicate-same-access+) + (if duplicated + (prog1 handle (real-crt-close fd)) + (win32-error 'duplicate-and-unwrap-fd))))) + +(define-alien-routine ("CreatePipe" create-pipe) lispbool + (read-pipe handle :out) + (write-pipe handle :out) + (security-attributes (* t)) + (buffer-size dword)) + +(defun windows-pipe () + (multiple-value-bind (created read-handle write-handle) + (create-pipe nil 256) + (if created (values read-handle write-handle) + (win32-error 'create-pipe)))) + +(defun windows-isatty (handle) + (if (= file-type-char (get-file-type handle)) + 1 0)) + +(defun inheritable-handle-p (handle) + (multiple-value-bind (got flags) + (get-handle-information handle) + (if got (plusp (logand flags +handle-flag-inherit+)) + (win32-error 'inheritable-handle-p)))) + +(defun (setf inheritable-handle-p) (allow handle) + (if (set-handle-information handle + +handle-flag-inherit+ + (if allow +handle-flag-inherit+ 0)) + allow + (win32-error '(setf inheritable-handle-p)))) + +(defun sb!unix:unix-dup (fd) + (let ((me (get-current-process))) + (multiple-value-bind (duplicated handle) + (duplicate-handle me fd me 0 t +duplicate-same-access+) + (if duplicated + (values handle 0) + (values nil (- (get-last-error))))))) + +(defun call-with-crt-fd (thunk handle &optional (flags 0)) + (multiple-value-bind (duplicate errno) + (sb!unix:unix-dup handle) + (if duplicate + (let ((fd (real-open-osfhandle duplicate flags))) + (unwind-protect (funcall thunk fd) + (real-crt-close fd))) + (values nil errno))))