Further cleanups
parent
667345e883
commit
60818847da
|
@ -6,6 +6,118 @@ math.functions sequences namespaces words symbols system
|
|||
combinators.lib io.ports destructors math.bitfields.lib ;
|
||||
IN: io.windows.files
|
||||
|
||||
: open-file ( path access-mode create-mode flags -- handle )
|
||||
[
|
||||
>r >r share-mode security-attributes-inherit r> r>
|
||||
CreateFile-flags f CreateFile
|
||||
dup invalid-handle?
|
||||
<win32-file>
|
||||
|dispose
|
||||
dup add-completion
|
||||
] with-destructors ;
|
||||
|
||||
: open-pipe-r/w ( path -- win32-file )
|
||||
{ GENERIC_READ GENERIC_WRITE } flags
|
||||
OPEN_EXISTING 0 open-file ;
|
||||
|
||||
: open-read ( path -- win32-file )
|
||||
GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
|
||||
|
||||
: open-write ( path -- win32-file )
|
||||
GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
|
||||
|
||||
: (open-append) ( path -- win32-file )
|
||||
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
|
||||
|
||||
: open-existing ( path -- win32-file )
|
||||
{ GENERIC_READ GENERIC_WRITE } flags
|
||||
share-mode
|
||||
f
|
||||
OPEN_EXISTING
|
||||
FILE_FLAG_BACKUP_SEMANTICS
|
||||
f CreateFileW dup win32-error=0/f <win32-file> ;
|
||||
|
||||
: maybe-create-file ( path -- win32-file ? )
|
||||
#! return true if file was just created
|
||||
{ GENERIC_READ GENERIC_WRITE } flags
|
||||
share-mode
|
||||
f
|
||||
OPEN_ALWAYS
|
||||
0 CreateFile-flags
|
||||
f CreateFileW dup win32-error=0/f <win32-file>
|
||||
GetLastError ERROR_ALREADY_EXISTS = not ;
|
||||
|
||||
: set-file-pointer ( handle length method -- )
|
||||
>r dupd d>w/w <uint> r> SetFilePointer
|
||||
INVALID_SET_FILE_POINTER = [
|
||||
CloseHandle "SetFilePointer failed" throw
|
||||
] when drop ;
|
||||
|
||||
HOOK: open-append os ( path -- win32-file )
|
||||
|
||||
TUPLE: FileArgs
|
||||
hFile lpBuffer nNumberOfBytesToRead
|
||||
lpNumberOfBytesRet lpOverlapped ;
|
||||
|
||||
C: <FileArgs> FileArgs
|
||||
|
||||
: make-FileArgs ( port -- <FileArgs> )
|
||||
{
|
||||
[ handle>> handle>> ]
|
||||
[ buffer>> ]
|
||||
[ buffer>> buffer-length ]
|
||||
[ drop "DWORD" <c-object> ]
|
||||
[ FileArgs-overlapped ]
|
||||
} cleave <FileArgs> ;
|
||||
|
||||
: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
|
||||
{
|
||||
[ hFile>> ]
|
||||
[ lpBuffer>> buffer-end ]
|
||||
[ lpBuffer>> buffer-capacity ]
|
||||
[ lpNumberOfBytesRet>> ]
|
||||
[ lpOverlapped>> ]
|
||||
} cleave ;
|
||||
|
||||
: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
|
||||
{
|
||||
[ hFile>> ]
|
||||
[ lpBuffer>> buffer@ ]
|
||||
[ lpBuffer>> buffer-length ]
|
||||
[ lpNumberOfBytesRet>> ]
|
||||
[ lpOverlapped>> ]
|
||||
} cleave ;
|
||||
|
||||
M: windows (file-reader) ( path -- stream )
|
||||
open-read <input-port> ;
|
||||
|
||||
M: windows (file-writer) ( path -- stream )
|
||||
open-write <output-port> ;
|
||||
|
||||
M: windows (file-appender) ( path -- stream )
|
||||
open-append <output-port> ;
|
||||
|
||||
M: windows move-file ( from to -- )
|
||||
[ normalize-path ] bi@ MoveFile win32-error=0/f ;
|
||||
|
||||
M: windows delete-file ( path -- )
|
||||
normalize-path DeleteFile win32-error=0/f ;
|
||||
|
||||
M: windows copy-file ( from to -- )
|
||||
dup parent-directory make-directories
|
||||
[ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
|
||||
|
||||
M: windows make-directory ( path -- )
|
||||
normalize-path
|
||||
f CreateDirectory win32-error=0/f ;
|
||||
|
||||
M: windows delete-directory ( path -- )
|
||||
normalize-path
|
||||
RemoveDirectory win32-error=0/f ;
|
||||
|
||||
M: windows normalize-directory ( string -- string )
|
||||
normalize-path "\\" ?tail drop "\\*" append ;
|
||||
|
||||
SYMBOLS: +read-only+ +hidden+ +system+
|
||||
+archive+ +device+ +normal+ +temporary+
|
||||
+sparse-file+ +reparse-point+ +compressed+ +offline+
|
||||
|
@ -133,6 +245,6 @@ M: winnt link-info ( path -- info )
|
|||
M: winnt touch-file ( path -- )
|
||||
[
|
||||
normalize-path
|
||||
maybe-create-file >r &close-handle r>
|
||||
maybe-create-file >r &dispose r>
|
||||
[ drop ] [ f now dup (set-file-times) ] if
|
||||
] with-destructors ;
|
||||
|
|
|
@ -19,8 +19,7 @@ TUPLE: CreateProcess-args
|
|||
lpEnvironment
|
||||
lpCurrentDirectory
|
||||
lpStartupInfo
|
||||
lpProcessInformation
|
||||
stdout-pipe stdin-pipe ;
|
||||
lpProcessInformation ;
|
||||
|
||||
: default-CreateProcess-args ( -- obj )
|
||||
CreateProcess-args new
|
||||
|
@ -31,18 +30,7 @@ TUPLE: CreateProcess-args
|
|||
0 >>dwCreateFlags ;
|
||||
|
||||
: call-CreateProcess ( CreateProcess-args -- )
|
||||
{
|
||||
lpApplicationName>>
|
||||
lpCommandLine>>
|
||||
lpProcessAttributes>>
|
||||
lpThreadAttributes>>
|
||||
bInheritHandles>>
|
||||
dwCreateFlags>>
|
||||
lpEnvironment>>
|
||||
lpCurrentDirectory>>
|
||||
lpStartupInfo>>
|
||||
lpProcessInformation>>
|
||||
} get-slots CreateProcess win32-error=0/f ;
|
||||
CreateProcess-args >tuple< CreateProcess win32-error=0/f ;
|
||||
|
||||
: count-trailing-backslashes ( str n -- str n )
|
||||
>r "\\" ?tail [
|
||||
|
|
|
@ -10,7 +10,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
|||
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
|
||||
|
||||
: (open-process-token) ( handle -- handle )
|
||||
TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY bitor "PHANDLE" <c-object>
|
||||
{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>
|
||||
[ OpenProcessToken win32-error=0/f ] keep *void* ;
|
||||
|
||||
: open-process-token ( -- handle )
|
||||
|
|
|
@ -101,3 +101,39 @@ M: winnt init-io ( -- )
|
|||
<master-completion-port> master-completion-port set-global
|
||||
H{ } clone io-hash set-global
|
||||
windows.winsock:init-winsock ;
|
||||
|
||||
: finish-flush ( n port -- )
|
||||
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
|
||||
|
||||
: ((wait-to-write)) ( port -- )
|
||||
dup make-FileArgs
|
||||
tuck setup-write WriteFile
|
||||
dupd overlapped-error? [
|
||||
>r lpOverlapped>> r>
|
||||
[ twiddle-thumbs ] keep
|
||||
[ finish-flush ] keep
|
||||
dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
M: winnt (wait-to-write)
|
||||
[ [ ((wait-to-write)) ] with-timeout ] with-destructors ;
|
||||
|
||||
: finish-read ( n port -- )
|
||||
over zero? [
|
||||
t >>eof 2drop
|
||||
] [
|
||||
[ buffer>> n>buffer ] [ update-file-ptr ] bi
|
||||
] if ;
|
||||
|
||||
: ((wait-to-read)) ( port -- )
|
||||
dup make-FileArgs
|
||||
tuck setup-read ReadFile
|
||||
dupd overlapped-error? [
|
||||
>r lpOverlapped>> r>
|
||||
[ twiddle-thumbs ] [ finish-read ] bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
M: winnt (wait-to-read) ( port -- )
|
||||
[ [ ((wait-to-read)) ] with-timeout ] with-destructors ;
|
||||
|
|
|
@ -29,6 +29,7 @@ M: winnt root-directory? ( path -- ? )
|
|||
} cond nip ;
|
||||
|
||||
ERROR: not-absolute-path ;
|
||||
|
||||
: root-directory ( string -- string' )
|
||||
{
|
||||
[ dup length 2 >= ]
|
||||
|
@ -58,39 +59,3 @@ M: winnt open-append
|
|||
|
||||
: update-file-ptr ( n port -- )
|
||||
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
|
||||
|
||||
: finish-flush ( n port -- )
|
||||
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
|
||||
|
||||
: ((wait-to-write)) ( port -- )
|
||||
dup make-FileArgs
|
||||
tuck setup-write WriteFile
|
||||
dupd overlapped-error? [
|
||||
>r lpOverlapped>> r>
|
||||
[ twiddle-thumbs ] keep
|
||||
[ finish-flush ] keep
|
||||
dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
M: winnt (wait-to-write)
|
||||
[ [ ((wait-to-write)) ] with-timeout ] with-destructors ;
|
||||
|
||||
: finish-read ( n port -- )
|
||||
over zero? [
|
||||
t >>eof 2drop
|
||||
] [
|
||||
[ buffer>> n>buffer ] [ update-file-ptr ] bi
|
||||
] if ;
|
||||
|
||||
: ((wait-to-read)) ( port -- )
|
||||
dup make-FileArgs
|
||||
tuck setup-read ReadFile
|
||||
dupd overlapped-error? [
|
||||
>r lpOverlapped>> r>
|
||||
[ twiddle-thumbs ] [ finish-read ] bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
M: winnt (wait-to-read) ( port -- )
|
||||
[ [ ((wait-to-read)) ] with-timeout ] with-destructors ;
|
||||
|
|
|
@ -21,10 +21,10 @@ IN: io.windows.nt.launcher
|
|||
|
||||
! /dev/null simulation
|
||||
: null-input ( -- pipe )
|
||||
(pipe) [ in>> handle>> ] [ out>> close-handle ] bi ;
|
||||
(pipe) [ in>> handle>> ] [ out>> dispose ] bi ;
|
||||
|
||||
: null-output ( -- pipe )
|
||||
(pipe) [ in>> close-handle ] [ out>> handle>> ] bi ;
|
||||
(pipe) [ in>> dispose ] [ out>> handle>> ] bi ;
|
||||
|
||||
: null-pipe ( mode -- pipe )
|
||||
{
|
||||
|
@ -49,7 +49,7 @@ IN: io.windows.nt.launcher
|
|||
create-mode
|
||||
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
||||
f ! template file
|
||||
CreateFile dup invalid-handle? &close-handle ;
|
||||
CreateFile dup invalid-handle? <win32-file> &dispose ;
|
||||
|
||||
: redirect-append ( default path access-mode create-mode -- handle )
|
||||
>r >r path>> r> r>
|
||||
|
@ -77,16 +77,12 @@ IN: io.windows.nt.launcher
|
|||
[ redirect-stream ]
|
||||
} cond ;
|
||||
|
||||
: default-stdout ( args -- handle )
|
||||
stdout-pipe>> dup [ out>> ] when ;
|
||||
|
||||
: redirect-stdout ( process args -- handle )
|
||||
default-stdout
|
||||
swap stdout>>
|
||||
stdout>>
|
||||
GENERIC_WRITE
|
||||
CREATE_ALWAYS
|
||||
redirect
|
||||
STD_OUTPUT_HANDLE GetStdHandle or ;
|
||||
STD_OUTPUT_HANDLE GetStdHandle ;
|
||||
|
||||
: redirect-stderr ( process args -- handle )
|
||||
over stderr>> +stdout+ eq? [
|
||||
|
@ -103,16 +99,12 @@ IN: io.windows.nt.launcher
|
|||
STD_ERROR_HANDLE GetStdHandle or
|
||||
] if ;
|
||||
|
||||
: default-stdin ( args -- handle )
|
||||
stdin-pipe>> dup [ in>> ] when ;
|
||||
|
||||
: redirect-stdin ( process args -- handle )
|
||||
default-stdin
|
||||
swap stdin>>
|
||||
stdin>>
|
||||
GENERIC_READ
|
||||
OPEN_EXISTING
|
||||
redirect
|
||||
STD_INPUT_HANDLE GetStdHandle or ;
|
||||
STD_INPUT_HANDLE GetStdHandle ;
|
||||
|
||||
M: winnt fill-redirection ( process args -- )
|
||||
[ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
|
||||
|
|
|
@ -19,9 +19,9 @@ IN: io.windows.nt.monitors
|
|||
f
|
||||
CreateFile
|
||||
dup invalid-handle?
|
||||
<win32-file>
|
||||
|close-handle
|
||||
dup add-completion
|
||||
f <win32-file> ;
|
||||
dup add-completion ;
|
||||
|
||||
TUPLE: win32-monitor-port < input-port recursive ;
|
||||
|
||||
|
@ -83,7 +83,7 @@ TUPLE: win32-monitor < monitor port ;
|
|||
] each ;
|
||||
|
||||
: fill-queue ( monitor -- )
|
||||
dup port>> check-closed
|
||||
dup port>> dup check-disposed
|
||||
[ buffer>> ptr>> ] [ read-changes zero? ] bi
|
||||
[ 2dup parse-notify-records ] unless
|
||||
2drop ;
|
||||
|
|
|
@ -19,8 +19,8 @@ IN: io.windows.nt.pipes
|
|||
security-attributes-inherit
|
||||
CreateNamedPipe
|
||||
dup win32-error=0/f
|
||||
dup add-completion
|
||||
f <win32-file> ;
|
||||
<win32-file> |dispose
|
||||
dup add-completion ;
|
||||
|
||||
: open-other-end ( name -- handle )
|
||||
GENERIC_WRITE
|
||||
|
@ -31,8 +31,8 @@ IN: io.windows.nt.pipes
|
|||
f
|
||||
CreateFile
|
||||
dup win32-error=0/f
|
||||
dup add-completion
|
||||
f <win32-file> ;
|
||||
<win32-file> |dispose
|
||||
dup add-completion ;
|
||||
|
||||
: unique-pipe-name ( -- string )
|
||||
[
|
||||
|
@ -47,7 +47,6 @@ IN: io.windows.nt.pipes
|
|||
M: winnt (pipe) ( -- pipe )
|
||||
[
|
||||
unique-pipe-name
|
||||
[ create-named-pipe |close-handle ]
|
||||
[ open-other-end |close-handle ]
|
||||
bi pipe boa
|
||||
[ create-named-pipe ] [ open-other-end ] bi
|
||||
pipe boa
|
||||
] with-destructors ;
|
||||
|
|
|
@ -11,6 +11,9 @@ IN: io.windows.nt.sockets
|
|||
M: winnt WSASocket-flags ( -- DWORD )
|
||||
WSA_FLAG_OVERLAPPED ;
|
||||
|
||||
: wait-for-socket ( args -- n )
|
||||
[ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
|
||||
|
||||
: get-ConnectEx-ptr ( socket -- void* )
|
||||
SIO_GET_EXTENSION_FUNCTION_POINTER
|
||||
WSAID_CONNECTEX
|
||||
|
@ -46,28 +49,13 @@ TUPLE: ConnectEx-args port
|
|||
"stdcall" alien-indirect drop
|
||||
winsock-error-string [ throw ] when* ;
|
||||
|
||||
: (wait-to-connect) ( client-out handle -- )
|
||||
overlapped>> swap twiddle-thumbs drop ;
|
||||
|
||||
: get-socket-name ( socket addrspec -- sockaddr )
|
||||
>r handle>> r> empty-sockaddr/size
|
||||
[ getsockname socket-error ] 2keep drop ;
|
||||
|
||||
M: win32-socket wait-to-connect ( client-out handle remote -- sockaddr )
|
||||
[
|
||||
[ drop (wait-to-connect) ]
|
||||
[ get-socket-name nip ]
|
||||
3bi
|
||||
] keep parse-sockaddr ;
|
||||
|
||||
M: object ((client)) ( addrspec -- handle )
|
||||
dup make-sockaddr/size <ConnectEx-args>
|
||||
over tcp-socket >>s*
|
||||
dup s*>> add-completion
|
||||
dup s*>> get-ConnectEx-ptr >>ptr*
|
||||
dup s*>> INADDR_ANY roll bind-socket
|
||||
dup call-ConnectEx
|
||||
dup [ s*>> ] [ lpOverlapped*>> ] bi <win32-socket> ;
|
||||
M: object establish-connection ( client-out remote -- )
|
||||
make-sockaddr/size <ConnectEx-args>
|
||||
swap >>port
|
||||
dup port>> handle>> handle>> >>s*
|
||||
dup s*>> get-ConnectEx-ptr >>ptr*
|
||||
dup call-ConnectEx
|
||||
wait-for-socket drop ;
|
||||
|
||||
TUPLE: AcceptEx-args port
|
||||
sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
|
||||
|
@ -82,75 +70,33 @@ TUPLE: AcceptEx-args port
|
|||
: <AcceptEx-args> ( server-port -- AcceptEx )
|
||||
AcceptEx-args new
|
||||
2dup init-accept-buffer
|
||||
over >>port
|
||||
over handle>> handle>> >>sListenSocket*
|
||||
over addr>> tcp-socket >>sAcceptSocket*
|
||||
swap >>port
|
||||
dup port>> handle>> handle>> >>sListenSocket*
|
||||
dup port>> addr>> tcp-socket >>sAcceptSocket*
|
||||
0 >>dwReceiveDataLength*
|
||||
f >>lpdwBytesReceived*
|
||||
(make-overlapped) >>lpOverlapped*
|
||||
nip ;
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
|
||||
: call-AcceptEx ( AcceptEx -- )
|
||||
AcceptEx-args >tuple*<
|
||||
AcceptEx drop
|
||||
AcceptEx-args >tuple*< AcceptEx drop
|
||||
winsock-error-string [ throw ] when* ;
|
||||
|
||||
: extract-remote-host ( AcceptEx -- addrspec )
|
||||
{
|
||||
[ lpOutputBuffer*>> ]
|
||||
[ dwReceiveDataLength*>> ]
|
||||
[ dwLocalAddressLength*>> ]
|
||||
[ dwRemoteAddressLength*>> ]
|
||||
} cleave
|
||||
f <void*>
|
||||
0 <int>
|
||||
f <void*> [
|
||||
0 <int> GetAcceptExSockaddrs
|
||||
] keep *void* ;
|
||||
: finish-accept ( AcceptEx -- client )
|
||||
sAcceptSocket*>> [ <win32-socket> |dispose ] [ add-completion ] bi ;
|
||||
|
||||
: finish-accept ( AcceptEx -- client sockaddr )
|
||||
[ sAcceptSocket*>> add-completion ]
|
||||
[ [ sAcceptSocket*>> ] [ lpOverlapped*>> ] bi <win32-socket> ]
|
||||
[ extract-remote-host ]
|
||||
tri ;
|
||||
|
||||
: wait-to-accept ( AcceptEx -- )
|
||||
[ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs drop ;
|
||||
|
||||
M: winnt (accept) ( server -- handle sockaddr )
|
||||
M: winnt (accept) ( server -- handle )
|
||||
[
|
||||
[
|
||||
<AcceptEx-args>
|
||||
{
|
||||
[ call-AcceptEx ]
|
||||
[ wait-to-accept ]
|
||||
[ wait-for-socket drop ]
|
||||
[ finish-accept ]
|
||||
[ port>> pending-error ]
|
||||
} cleave
|
||||
] with-timeout
|
||||
] with-destructors ;
|
||||
|
||||
M: winnt (server) ( addrspec -- handle sockaddr )
|
||||
[
|
||||
[ SOCK_STREAM server-fd ] keep
|
||||
[
|
||||
drop
|
||||
[ listen-on-socket ]
|
||||
[ add-completion ]
|
||||
[ f <win32-socket> ]
|
||||
tri
|
||||
]
|
||||
[ get-socket-name ]
|
||||
2bi
|
||||
] with-destructors ;
|
||||
|
||||
M: winnt (datagram) ( addrspec -- handle )
|
||||
[
|
||||
SOCK_DGRAM server-fd
|
||||
dup add-completion
|
||||
f <win32-socket>
|
||||
] with-destructors ;
|
||||
|
||||
TUPLE: WSARecvFrom-args port
|
||||
s* lpBuffers* dwBufferCount* lpNumberOfBytesRecvd*
|
||||
lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ;
|
||||
|
@ -162,9 +108,9 @@ TUPLE: WSARecvFrom-args port
|
|||
|
||||
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
|
||||
WSARecvFrom new
|
||||
over >>port
|
||||
over handle>> handle>> >>s*
|
||||
swap addr>> sockaddr-type heap-size
|
||||
swap >>port
|
||||
dup port>> handle>> handle>> >>s*
|
||||
dup port>> addr>> sockaddr-type heap-size
|
||||
[ malloc &free >>lpFrom* ]
|
||||
[ malloc-int &free >>lpFromLen* ] bi
|
||||
make-receive-buffer >>lpBuffers*
|
||||
|
@ -173,23 +119,18 @@ TUPLE: WSARecvFrom-args port
|
|||
0 malloc-int &free >>lpNumberOfBytesRecvd*
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
|
||||
: wait-to-receive ( WSARecvFrom -- n )
|
||||
[ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
|
||||
|
||||
: call-WSARecvFrom ( WSARecvFrom -- )
|
||||
WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
|
||||
|
||||
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
|
||||
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ]
|
||||
[ lpFrom*>> ]
|
||||
bi ;
|
||||
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ;
|
||||
|
||||
M: winnt receive ( datagram -- packet addrspec )
|
||||
[
|
||||
<WSARecvFrom-args>
|
||||
{
|
||||
[ call-WSARecvFrom ]
|
||||
[ wait-to-receive ]
|
||||
[ wait-for-socket ]
|
||||
[ port>> pending-error ]
|
||||
[ parse-WSARecvFrom ]
|
||||
} cleave
|
||||
|
@ -208,8 +149,8 @@ TUPLE: WSASendTo-args port
|
|||
|
||||
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
|
||||
WSASendTo-args new
|
||||
over >>port
|
||||
over handle>> handle>> >>s*
|
||||
swap >>port
|
||||
dup port>> handle>> handle>> >>s*
|
||||
swap make-sockaddr/size
|
||||
>r malloc-byte-array &free
|
||||
r> [ >>lpTo* ] [ >>iToLen* ] bi*
|
||||
|
@ -219,19 +160,14 @@ TUPLE: WSASendTo-args port
|
|||
0 <uint> >>lpNumberOfBytesSent*
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
|
||||
: wait-to-send ( WSASendTo -- )
|
||||
[ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs drop ;
|
||||
|
||||
: call-WSASendTo ( WSASendTo -- )
|
||||
WSASendTo-args >tuple*< WSASendTo socket-error* ;
|
||||
|
||||
USE: io.sockets
|
||||
|
||||
M: winnt send ( packet addrspec datagram -- )
|
||||
[
|
||||
<WSASendTo-args>
|
||||
[ call-WSASendTo ]
|
||||
[ wait-to-send ]
|
||||
[ wait-for-socket drop ]
|
||||
[ port>> pending-error ]
|
||||
tri
|
||||
] with-destructors ;
|
||||
|
|
|
@ -0,0 +1,53 @@
|
|||
USING: kernel accessors io.sockets io.windows
|
||||
windows.winsock system ;
|
||||
IN: io.windows.sockets
|
||||
|
||||
HOOK: WSASocket-flags io-backend ( -- DWORD )
|
||||
|
||||
TUPLE: win32-socket < win32-file ;
|
||||
|
||||
: <win32-socket> ( handle -- win32-socket )
|
||||
win32-socket new
|
||||
swap >>handle ;
|
||||
|
||||
M: win32-socket dispose ( stream -- )
|
||||
handle>> closesocket drop ;
|
||||
|
||||
: unspecific-sockaddr/size ( addrspec -- sockaddr len )
|
||||
[ empty-sockaddr/size ] [ protocol-family ] bi
|
||||
pick set-sockaddr-in-family ;
|
||||
|
||||
: open-socket ( addrspec type -- win3-socket )
|
||||
>r protocol-family r>
|
||||
0 f 0 WSASocket-flags WSASocket
|
||||
dup socket-error
|
||||
<win32-socket> |dispose
|
||||
dup add-completion ;
|
||||
|
||||
M: object get-local-address ( socket addrspec -- sockaddr )
|
||||
>r handle>> r> empty-sockaddr/size
|
||||
[ getsockname socket-error ] 2keep drop ;
|
||||
|
||||
M: object ((client)) ( addrspec -- handle )
|
||||
[ open-socket ] [ drop ] 2bi
|
||||
[ unspecific-sockaddr/size bind socket-error ] [ drop ] 2bi ;
|
||||
|
||||
: server-socket ( addrspec type -- fd )
|
||||
[ open-socket ] [ drop ] 2bi
|
||||
[ make-sockaddr/size bind socket-error ] [ drop ] 2bi ;
|
||||
|
||||
! http://support.microsoft.com/kb/127144
|
||||
! NOTE: Possibly tweak this because of SYN flood attacks
|
||||
: listen-backlog ( -- n ) HEX: 7fffffff ; inline
|
||||
|
||||
M: object (server) ( addrspec -- handle )
|
||||
[
|
||||
SOCK_STREAM server-socket
|
||||
dup handle>> listen-backlog listen winsock-return-check
|
||||
] with-destructors ;
|
||||
|
||||
M: windows (datagram) ( addrspec -- handle )
|
||||
[ SOCK_DGRAM server-socket ] with-destructors ;
|
||||
|
||||
M: windows addrinfo-error ( n -- )
|
||||
winsock-return-check ;
|
Loading…
Reference in New Issue