;;; 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)
;;; 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)
;;;; 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)
;;; 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)
;;; 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)
;;; 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
(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
;;;; System Functions
#!-sb-thread
-(define-alien-routine ("Sleep@4" millisleep) void
+(define-alien-routine ("Sleep" millisleep) void
(milliseconds dword))
#!+sb-thread
(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)
(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))))
(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)))))
(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))
(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)
`(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.
(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)
(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)))
(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"))
(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)
;;
;; 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
(,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)
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)))
"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
;; 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)
(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)
(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)
(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"
(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"
(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))
;; -- 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)
;;; ...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))))
projects / sbcl.git / blobdiff