#!-sb-unicode c-string
#!+sb-unicode (c-string :external-format :ucs-2))
+(define-alien-type tchar #!-sb-unicode char
+ #!+sb-unicode (unsigned 16))
+
(defconstant default-environment-length 1024)
;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
;;; to a pointer.
(defconstant invalid-handle -1)
+(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)
+
+;; 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))
+
;;;; Error Handling
;;; Retrieve the calling thread's last-error code value. The
;;; last-error code is maintained on a per-thread basis.
(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" format-message) dword
- (flags dword)
- (source (* t))
- (message-id dword)
- (language-id dword)
- (buffer c-string)
- (size dword)
- (arguments (* t)))
-
;;;; 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
(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
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
(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)
(defmacro make-system-buffer (x)
`(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x))
+(defmacro with-handle ((var initform
+ &key (close-operator 'close-handle))
+ &body body)
+ `(without-interrupts
+ (block nil
+ (let ((,var ,initform))
+ (unwind-protect
+ (with-local-interrupts
+ ,@body)
+ (,close-operator ,var))))))
+
+(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)
+
+(defmacro decode-system-string (alien)
+ `(cast (cast ,alien (* char)) system-string))
+
;;; 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.
(defmacro void-syscall* ((name &rest arg-types) &rest args)
`(syscall* (,name ,@arg-types) (values t 0) ,@args))
-(defun get-last-error-message (err)
+(defun format-system-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" 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)
- 0 err 0 (addr amsg) 0 0)))
+ (let ((message
+ (with-alien ((amsg (* char)))
+ (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
+ format-message-max-width-mask
+ format-message-ignore-inserts)
+ 0 err 0 (addr amsg) 0 0))))
+ (and message (string-right-trim '(#\Space) message))))
(defmacro win32-error (func-name &optional err)
`(let ((err-code ,(or err `(get-last-error))))
(error "~%Win32 Error [~A] - ~A~%~A"
,func-name
err-code
- (get-last-error-message err-code))))
+ (format-system-message err-code))))
(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))))
+ (with-alien ((apath pathname-buffer))
(syscall (("SHGetFolderPath" t) int handle int handle dword (* char))
- (concatenate 'string (cast-and-free apath) "\\")
- 0 csidl 0 0 apath)))
+ (concatenate 'string (decode-system-string apath) "\\")
+ 0 csidl 0 0 (cast apath (* char)))))
(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-alien ((apath pathname-buffer))
(with-sysfun (afunc ("GetCurrentDirectory" t) dword dword (* char))
- (let ((ret (alien-funcall afunc (1+ max_path) apath)))
+ (let ((ret (alien-funcall afunc (1+ max_path) (cast apath (* char)))))
(when (zerop ret)
(win32-error "GetCurrentDirectory"))
- (when (> ret (1+ max_path))
- (free-alien apath)
- (setf apath (make-system-buffer ret))
- (alien-funcall afunc ret apath))
- (cast-and-free apath)))))
+ (if (> ret (1+ max_path))
+ (with-alien ((apath (* char) (make-system-buffer ret)))
+ (alien-funcall afunc ret apath)
+ (cast-and-free apath))
+ (decode-system-string apath))))))
(defun sb!unix:unix-mkdir (name mode)
(declare (type sb!unix:unix-pathname name)
(type sb!unix:unix-file-mode mode)
(ignore mode))
- (void-syscall* (("CreateDirectory" t) system-string dword) name 0))
+ (syscall (("CreateDirectory" t) lispbool system-string (* t))
+ (values result (if result 0 (get-last-error)))
+ name nil))
(defun sb!unix:unix-rename (name1 name2)
(declare (type sb!unix:unix-pathname name1 name2))
- (void-syscall* (("MoveFile" t) system-string system-string) name1 name2))
+ (syscall (("MoveFile" t) lispbool system-string system-string)
+ (values result (if result 0 (get-last-error)))
+ name1 name2))
(defun sb!unix::posix-getenv (name)
(declare (type simple-string name))
;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp?
(define-alien-type FILETIME (sb!alien:unsigned 64))
+;; FILETIME definition above is almost correct (on little-endian systems),
+;; except for the wrong alignment if used in another structure: the real
+;; definition is a struct of two dwords.
+;; Let's define FILETIME-MEMBER for that purpose; it will be useful with
+;; GetFileAttributesEx and FindFirstFileExW.
+
+(define-alien-type FILETIME-MEMBER
+ (struct nil (low dword) (high dword)))
+
(defmacro with-process-times ((creation-time exit-time kernel-time user-time)
&body forms)
`(with-alien ((,creation-time filetime)
;; (addr epoch)
;; (addr filetime)))
(defconstant +unix-epoch-filetime+ 116444736000000000)
+(defconstant +filetime-unit+ (* 100ns-per-internal-time-unit
+ internal-time-units-per-second))
+(defconstant +common-lisp-epoch-filetime-seconds+ 9435484800)
#!-sb-fluid
(declaim (inline get-time-of-day))
(values sec (floor 100ns 10)))
(addr system-time))))
+;; Data for FindFirstFileExW and GetFileAttributesEx
+(define-alien-type find-data
+ (struct nil
+ (attributes dword)
+ (ctime filetime-member)
+ (atime filetime-member)
+ (mtime filetime-member)
+ (size-low dword)
+ (size-high dword)
+ (reserved0 dword)
+ (reserved1 dword)
+ (long-name (array tchar #.max_path))
+ (short-name (array tchar 14))))
+
+(define-alien-type file-attributes
+ (struct nil
+ (attributes dword)
+ (ctime filetime-member)
+ (atime filetime-member)
+ (mtime filetime-member)
+ (size-low dword)
+ (size-high dword)))
+
+(define-alien-routine ("FindClose" find-close) lispbool
+ (handle handle))
+
+(defun attribute-file-kind (dword)
+ (if (logtest file-attribute-directory dword)
+ :directory :file))
+
+(defun native-file-write-date (native-namestring)
+ "Return file write date, represented as CL universal time."
+ (with-alien ((file-attributes file-attributes))
+ (syscall (("GetFileAttributesEx" t) lispbool
+ system-string int file-attributes)
+ (and result
+ (- (floor (deref (cast (slot file-attributes 'mtime)
+ (* filetime)))
+ +filetime-unit+)
+ +common-lisp-epoch-filetime-seconds+))
+ native-namestring 0 file-attributes)))
+
+(defun native-probe-file-name (native-namestring)
+ "Return truename \(using GetLongPathName\) as primary value,
+File kind as secondary.
+
+Unless kind is false, null truename shouldn't be interpreted as error or file
+absense."
+ (with-alien ((file-attributes file-attributes)
+ (buffer long-pathname-buffer))
+ (syscall (("GetFileAttributesEx" t) lispbool
+ system-string int file-attributes)
+ (values
+ (syscall (("GetLongPathName" t) dword
+ system-string long-pathname-buffer dword)
+ (and (plusp result) (decode-system-string buffer))
+ native-namestring buffer 32768)
+ (and result
+ (attribute-file-kind
+ (slot file-attributes 'attributes))))
+ native-namestring 0 file-attributes)))
+
+(defun native-delete-file (native-namestring)
+ (syscall (("DeleteFile" t) lispbool system-string)
+ result native-namestring))
+
+(defun native-delete-directory (native-namestring)
+ (syscall (("RemoveDirectory" t) lispbool system-string)
+ result native-namestring))
+
+(defun native-call-with-directory-iterator (function namestring errorp)
+ (declare (type (or null string) namestring)
+ (function function))
+ (when namestring
+ (with-alien ((find-data find-data))
+ (with-handle (handle (syscall (("FindFirstFile" t) handle
+ system-string find-data)
+ (if (eql result invalid-handle)
+ (if errorp
+ (win32-error "FindFirstFile")
+ (return))
+ result)
+ (concatenate 'string
+ namestring "*.*")
+ find-data)
+ :close-operator find-close)
+ (let ((more t))
+ (dx-flet ((one-iter ()
+ (tagbody
+ :next
+ (when more
+ (let ((name (decode-system-string
+ (slot find-data 'long-name)))
+ (attributes (slot find-data 'attributes)))
+ (setf more
+ (syscall (("FindNextFile" t) lispbool
+ handle find-data) result
+ handle find-data))
+ (cond ((equal name ".") (go :next))
+ ((equal name "..") (go :next))
+ (t
+ (return-from one-iter
+ (values name
+ (attribute-file-kind
+ attributes))))))))))
+ (funcall function #'one-iter)))))))
+
;; SETENV
;; The SetEnvironmentVariable function sets the contents of the specified
;; environment variable for the current process.
;;
;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp
(defun setenv (name value)
- (declare (type simple-string name value))
- (void-syscall* (("SetEnvironmentVariable" t) system-string system-string)
- name value))
+ (declare (type (or null simple-string) value))
+ (if value
+ (void-syscall* (("SetEnvironmentVariable" t) system-string system-string)
+ name value)
+ (void-syscall* (("SetEnvironmentVariable" t) system-string int-ptr)
+ name 0)))
+
+;; Let SETENV be an accessor for POSIX-GETENV.
+;;
+;; DFL: Merged this function because it seems useful to me. But
+;; shouldn't we then define it on actual POSIX, too?
+(defun (setf sb!unix::posix-getenv) (new-value name)
+ (if (setenv name new-value)
+ new-value
+ (posix-getenv name)))
(defmacro c-sizeof (s)
"translate alien size (in bits) to c-size (in bytes)"
(alien-funcall afunc aname (addr length))))
(cast-and-free aname))))
-(define-alien-routine ("_lseeki64" lseeki64)
- (signed 64)
- (fd int)
- (position (signed 64))
- (whence int))
-
(define-alien-routine ("SetFilePointerEx" set-file-pointer-ex) lispbool
(handle handle)
(offset long-long)
(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"
(protection dword)
(maximum-size-high dword)
(maximum-size-low dword)
- (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
+ (name system-string))
(define-alien-routine ("MapViewOfFile" map-view-of-file)
system-area-pointer
(defconstant access-generic-execute #x20000000)
(defconstant access-generic-all #x10000000)
(defconstant access-file-append-data #x4)
+(defconstant access-delete #x00010000)
;; share modes
(defconstant file-share-delete #x04)
(defconstant file-share-read #x01)
(defconstant file-share-write #x02)
-;; CreateFile (the real file-opening workhorse)
+;; CreateFile (the real file-opening workhorse).
(define-alien-routine (#!+sb-unicode "CreateFileW"
#!-sb-unicode "CreateFileA"
create-file)
(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)
+;; GetFileSizeEx doesn't work with block devices :[
+(define-alien-routine ("GetFileSizeEx" get-file-size-ex)
+ bool
+ (handle handle) (file-size (signed 64) :in-out))
;; GetFileAttribute is like a tiny subset of fstat(),
;; enough to distinguish directories from anything else.
(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))
sb!unix:enoent)
((#.error_already_exists #.error_file_exists)
sb!unix:eexist)
- (otherwise (- error-code)))))
+ (otherwise error-code))))
(progn
;; FIXME: seeking to the end is not enough for real APPEND
;; semantics, but it's better than nothing.
;; -- 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))))
+
+;;; random seeding
+
+(define-alien-routine ("CryptGenRandom" %crypt-gen-random) lispbool
+ (handle handle)
+ (length dword)
+ (buffer (* t)))
+
+(define-alien-routine (#!-sb-unicode "CryptAcquireContextA"
+ #!+sb-unicode "CryptAcquireContextW"
+ %crypt-acquire-context) lispbool
+ (handle handle :out)
+ (container system-string)
+ (provider system-string)
+ (provider-type dword)
+ (flags dword))
+
+(define-alien-routine ("CryptReleaseContext" %crypt-release-context) lispbool
+ (handle handle)
+ (flags dword))
+
+(defun crypt-gen-random (length)
+ (multiple-value-bind (ok context)
+ (%crypt-acquire-context nil nil prov-rsa-full
+ (logior crypt-verifycontext crypt-silent))
+ (unless ok
+ (return-from crypt-gen-random (values nil (get-last-error))))
+ (unwind-protect
+ (let ((data (make-array length :element-type '(unsigned-byte 8))))
+ (with-pinned-objects (data)
+ (if (%crypt-gen-random context length (vector-sap data))
+ data
+ (values nil (get-last-error)))))
+ (unless (%crypt-release-context context 0)
+ (win32-error '%crypt-release-context)))))
projects / sbcl.git / blobdiff