Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
d7b296211e
|
|
@ -0,0 +1,11 @@
|
|||
IN: libc.tests
|
||||
USING: libc libc.private tools.test namespaces assocs
|
||||
destructors kernel ;
|
||||
|
||||
100 malloc "block" set
|
||||
|
||||
[ t ] [ "block" get mallocs get key? ] unit-test
|
||||
|
||||
[ ] [ [ "block" get &free drop ] with-destructors ] unit-test
|
||||
|
||||
[ f ] [ "block" get mallocs get key? ] unit-test
|
||||
|
|
@ -81,14 +81,14 @@ PRIVATE>
|
|||
<PRIVATE
|
||||
|
||||
! Memory allocations
|
||||
TUPLE: memory-destructor alien ;
|
||||
TUPLE: memory-destructor alien disposed ;
|
||||
|
||||
M: memory-destructor dispose* alien>> free ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: &free ( alien -- alien )
|
||||
dup memory-destructor boa &dispose drop ; inline
|
||||
dup f memory-destructor boa &dispose drop ; inline
|
||||
|
||||
: |free ( alien -- alien )
|
||||
dup memory-destructor boa |dispose drop ; inline
|
||||
dup f memory-destructor boa |dispose drop ; inline
|
||||
|
|
|
|||
|
|
@ -16,6 +16,11 @@ HELP: <mapped-file>
|
|||
{ $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
HELP: with-mapped-file
|
||||
{ $values { "path" "a pathname string" } { "length" integer } { "quot" "a quotation with stack effect " { $snippet "( mmap -- )" } } }
|
||||
{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
HELP: close-mapped-file
|
||||
{ $values { "mmap" mapped-file } }
|
||||
{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }
|
||||
|
|
|
|||
|
|
@ -2,11 +2,14 @@ USING: io io.mmap io.files kernel tools.test continuations
|
|||
sequences io.encodings.ascii accessors ;
|
||||
IN: io.mmap.tests
|
||||
|
||||
[ "resource:mmap-test-file.txt" delete-file ] ignore-errors
|
||||
[ ] [ "12345" "resource:mmap-test-file.txt" ascii set-file-contents ] unit-test
|
||||
[ ] [ "resource:mmap-test-file.txt" dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "resource:mmap-test-file.txt" dup file-info size>> [ length ] with-mapped-file ] unit-test
|
||||
[ "22345" ] [ "resource:mmap-test-file.txt" ascii file-contents ] unit-test
|
||||
[ "resource:mmap-test-file.txt" delete-file ] ignore-errors
|
||||
|
||||
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
|
||||
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test
|
||||
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
|
||||
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
|
||||
|
||||
[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
|
||||
[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
|
||||
[ ] [ "mmap-grow-test.txt" temp-file 100 [ drop ] with-mapped-file ] unit-test
|
||||
[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -27,10 +27,10 @@ GENERIC: inet-ntop ( data addrspec -- str )
|
|||
GENERIC: inet-pton ( str addrspec -- data )
|
||||
|
||||
: make-sockaddr/size ( addrspec -- sockaddr size )
|
||||
dup make-sockaddr swap sockaddr-type heap-size ;
|
||||
[ make-sockaddr ] [ sockaddr-type heap-size ] bi ;
|
||||
|
||||
: empty-sockaddr/size ( addrspec -- sockaddr len )
|
||||
sockaddr-type [ <c-object> ] [ heap-size <int> ] bi ;
|
||||
: empty-sockaddr/size ( addrspec -- sockaddr size )
|
||||
sockaddr-type [ <c-object> ] [ heap-size ] bi ;
|
||||
|
||||
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: io.unix.mmap
|
|||
|
||||
: open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
|
||||
|
||||
:: mmap-open ( length prot flags path -- alien fd )
|
||||
:: mmap-open ( path length prot flags -- alien fd )
|
||||
[
|
||||
f length prot flags
|
||||
path open-r/w |dispose
|
||||
|
|
@ -14,10 +14,9 @@ IN: io.unix.mmap
|
|||
] with-destructors ;
|
||||
|
||||
M: unix (mapped-file)
|
||||
swap >r
|
||||
{ PROT_READ PROT_WRITE } flags
|
||||
{ MAP_FILE MAP_SHARED } flags
|
||||
r> mmap-open ;
|
||||
mmap-open ;
|
||||
|
||||
M: unix close-mapped-file ( mmap -- )
|
||||
[ [ address>> ] [ length>> ] bi munmap io-error ]
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ M: unix addrinfo-error ( n -- )
|
|||
|
||||
! Client sockets - TCP and Unix domain
|
||||
M: object (get-local-address) ( handle remote -- sockaddr )
|
||||
>r handle-fd r> empty-sockaddr/size
|
||||
>r handle-fd r> empty-sockaddr/size <int>
|
||||
[ getsockname io-error ] 2keep drop ;
|
||||
|
||||
: init-client-socket ( fd -- )
|
||||
|
|
@ -67,7 +67,7 @@ M: object (server) ( addrspec -- handle )
|
|||
] with-destructors ;
|
||||
|
||||
: do-accept ( server addrspec -- fd )
|
||||
[ handle>> handle-fd ] [ empty-sockaddr/size ] bi* accept ; inline
|
||||
[ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi* accept ; inline
|
||||
|
||||
M: object (accept) ( server addrspec -- fd )
|
||||
2dup do-accept
|
||||
|
|
@ -100,7 +100,7 @@ packet-size <byte-array> receive-buffer set-global
|
|||
packet-size ! nbytes
|
||||
0 ! flags
|
||||
sockaddr ! from
|
||||
len ! fromlen
|
||||
len <int> ! fromlen
|
||||
recvfrom dup 0 >= [
|
||||
receive-buffer get-global swap head sockaddr
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
IN: io.windows.ce.privileges
|
||||
USING: io.windows.privileges system ;
|
||||
|
||||
M: wince set-privilege 2drop ;
|
||||
|
|
@ -1,11 +1,121 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types io.backend io.files io.windows kernel math
|
||||
USING: alien.c-types io.binary io.backend io.files io.buffers
|
||||
io.windows kernel math splitting
|
||||
windows windows.kernel32 windows.time calendar combinators
|
||||
math.functions sequences namespaces words symbols system
|
||||
combinators.lib io.ports destructors math.bitfields.lib ;
|
||||
combinators.lib io.ports destructors accessors
|
||||
math.bitfields 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 opened-file
|
||||
] 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+
|
||||
|
|
@ -101,7 +211,7 @@ M: winnt link-info ( path -- info )
|
|||
|
||||
: file-times ( path -- timestamp timestamp timestamp )
|
||||
[
|
||||
normalize-path open-existing dup close-always
|
||||
normalize-path open-existing &dispose handle>>
|
||||
"FILETIME" <c-object>
|
||||
"FILETIME" <c-object>
|
||||
"FILETIME" <c-object>
|
||||
|
|
@ -117,7 +227,7 @@ M: winnt link-info ( path -- info )
|
|||
#! timestamp order: creation access write
|
||||
[
|
||||
>r >r >r
|
||||
normalize-path open-existing dup close-always
|
||||
normalize-path open-existing &dispose handle>>
|
||||
r> r> r> (set-file-times)
|
||||
] with-destructors ;
|
||||
|
||||
|
|
@ -133,6 +243,6 @@ M: winnt link-info ( path -- info )
|
|||
M: winnt touch-file ( path -- )
|
||||
[
|
||||
normalize-path
|
||||
maybe-create-file over close-always
|
||||
[ drop ] [ f now dup (set-file-times) ] if
|
||||
maybe-create-file >r &dispose r>
|
||||
[ drop ] [ handle>> f now dup (set-file-times) ] if
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: kernel system io.files.unique.backend
|
||||
windows.kernel32 io.windows io.ports windows ;
|
||||
windows.kernel32 io.windows io.windows.files io.ports windows
|
||||
destructors ;
|
||||
IN: io.windows.files.unique
|
||||
|
||||
M: windows (make-unique-file) ( path -- )
|
||||
GENERIC_WRITE CREATE_NEW 0 open-file
|
||||
CloseHandle win32-error=0/f ;
|
||||
GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
|
||||
|
||||
M: windows temporary-path ( -- path )
|
||||
"TEMP" os-env ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ windows.types math windows.kernel32
|
|||
namespaces io.launcher kernel sequences windows.errors
|
||||
splitting system threads init strings combinators
|
||||
io.backend accessors concurrency.flags io.files assocs
|
||||
io.files.private windows destructors ;
|
||||
io.files.private windows destructors classes.tuple.lib ;
|
||||
IN: io.windows.launcher
|
||||
|
||||
TUPLE: CreateProcess-args
|
||||
|
|
@ -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 [
|
||||
|
|
|
|||
|
|
@ -1,88 +1,44 @@
|
|||
USING: alien alien.c-types alien.syntax arrays continuations
|
||||
destructors generic io.mmap io.ports io.windows
|
||||
kernel libc math namespaces quotations sequences windows
|
||||
windows.advapi32 windows.kernel32 io.backend system ;
|
||||
USING: alien alien.c-types arrays destructors generic io.mmap
|
||||
io.ports io.windows io.windows.files io.windows.privileges
|
||||
kernel libc math math.bitfields namespaces quotations sequences
|
||||
windows windows.advapi32 windows.kernel32 io.backend system
|
||||
accessors locals ;
|
||||
IN: io.windows.mmap
|
||||
|
||||
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
||||
: create-file-mapping
|
||||
CreateFileMapping [ win32-error=0/f ] keep <win32-handle> ;
|
||||
|
||||
! Security tokens
|
||||
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
|
||||
: map-view-of-file
|
||||
MapViewOfFile [ win32-error=0/f ] keep ;
|
||||
|
||||
: (open-process-token) ( handle -- handle )
|
||||
TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY bitor "PHANDLE" <c-object>
|
||||
[ OpenProcessToken win32-error=0/f ] keep *void* ;
|
||||
:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
|
||||
[let | lo [ length HEX: ffffffff bitand ]
|
||||
hi [ length -32 shift HEX: ffffffff bitand ] |
|
||||
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
|
||||
path access-mode create-mode 0 open-file |dispose
|
||||
dup handle>> f protect hi lo f create-file-mapping |dispose
|
||||
dup handle>> access 0 0 0 map-view-of-file
|
||||
] with-privileges
|
||||
] ;
|
||||
|
||||
: open-process-token ( -- handle )
|
||||
#! remember to handle-close this
|
||||
GetCurrentProcess (open-process-token) ;
|
||||
TUPLE: win32-mapped-file file mapping ;
|
||||
|
||||
: with-process-token ( quot -- )
|
||||
#! quot: ( token-handle -- token-handle )
|
||||
>r open-process-token r>
|
||||
[ keep ] curry
|
||||
[ CloseHandle drop ] [ ] cleanup ; inline
|
||||
M: win32-mapped-file dispose
|
||||
[ file>> dispose ] [ mapping>> dispose ] bi ;
|
||||
|
||||
: lookup-privilege ( string -- luid )
|
||||
>r f r> "LUID" <c-object>
|
||||
[ LookupPrivilegeValue win32-error=0/f ] keep ;
|
||||
C: <win32-mapped-file> win32-mapped-file
|
||||
|
||||
: make-token-privileges ( name ? -- obj )
|
||||
"TOKEN_PRIVILEGES" <c-object>
|
||||
1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep
|
||||
"LUID_AND_ATTRIBUTES" malloc-array
|
||||
dup free-always over set-TOKEN_PRIVILEGES-Privileges
|
||||
|
||||
swap [
|
||||
SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
|
||||
set-LUID_AND_ATTRIBUTES-Attributes
|
||||
] when
|
||||
|
||||
>r lookup-privilege r>
|
||||
M: windows (mapped-file)
|
||||
[
|
||||
TOKEN_PRIVILEGES-Privileges
|
||||
>r 0 r> LUID_AND_ATTRIBUTES-nth
|
||||
set-LUID_AND_ATTRIBUTES-Luid
|
||||
] keep ;
|
||||
|
||||
: set-privilege ( name ? -- )
|
||||
[
|
||||
-rot 0 -rot make-token-privileges
|
||||
dup length f f AdjustTokenPrivileges win32-error=0/f
|
||||
] with-process-token ;
|
||||
|
||||
HOOK: with-privileges io-backend ( seq quot -- ) inline
|
||||
|
||||
M: winnt with-privileges
|
||||
over [ [ t set-privilege ] each ] curry compose
|
||||
swap [ [ f set-privilege ] each ] curry [ ] cleanup ;
|
||||
|
||||
M: wince with-privileges
|
||||
nip call ;
|
||||
|
||||
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
|
||||
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
|
||||
>r >r 0 open-file dup f r> 0 0 f
|
||||
CreateFileMapping [ win32-error=0/f ] keep
|
||||
dup close-later
|
||||
dup
|
||||
r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep
|
||||
dup close-later
|
||||
] with-privileges ;
|
||||
|
||||
M: windows (mapped-file) ( path length -- mmap )
|
||||
[
|
||||
swap
|
||||
GENERIC_WRITE GENERIC_READ bitor
|
||||
{ GENERIC_WRITE GENERIC_READ } flags
|
||||
OPEN_ALWAYS
|
||||
PAGE_READWRITE SEC_COMMIT bitor
|
||||
{ PAGE_READWRITE SEC_COMMIT } flags
|
||||
FILE_MAP_ALL_ACCESS mmap-open
|
||||
-rot 2array
|
||||
f \ mapped-file boa
|
||||
-rot <win32-mapped-file>
|
||||
] with-destructors ;
|
||||
|
||||
M: windows close-mapped-file ( mapped-file -- )
|
||||
[
|
||||
dup mapped-file-handle [ close-always ] each
|
||||
mapped-file-address UnmapViewOfFile win32-error=0/f
|
||||
[ handle>> &dispose drop ]
|
||||
[ address>> UnmapViewOfFile win32-error=0/f ] bi
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
USING: alien alien.c-types arrays assocs combinators
|
||||
continuations destructors io io.backend io.ports
|
||||
io.windows libc kernel math namespaces sequences
|
||||
threads classes.tuple.lib windows windows.errors
|
||||
windows.kernel32 strings splitting io.files qualified ascii
|
||||
combinators.lib system accessors ;
|
||||
continuations destructors io io.backend io.ports io.timeouts
|
||||
io.windows io.windows.files libc kernel math namespaces
|
||||
sequences threads classes.tuple.lib windows windows.errors
|
||||
windows.kernel32 strings splitting io.files
|
||||
io.buffers qualified ascii combinators.lib system
|
||||
accessors locals ;
|
||||
QUALIFIED: windows.winsock
|
||||
IN: io.windows.nt.backend
|
||||
|
||||
|
|
@ -14,11 +15,11 @@ TUPLE: io-callback port thread ;
|
|||
C: <io-callback> io-callback
|
||||
|
||||
: (make-overlapped) ( -- overlapped-ext )
|
||||
"OVERLAPPED" malloc-object dup free-always ;
|
||||
"OVERLAPPED" malloc-object &free ;
|
||||
|
||||
: make-overlapped ( port -- overlapped-ext )
|
||||
>r (make-overlapped) r> port-handle win32-file-ptr
|
||||
[ over set-OVERLAPPED-offset ] when* ;
|
||||
>r (make-overlapped)
|
||||
r> handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
|
||||
|
||||
: <completion-port> ( handle existing -- handle )
|
||||
f 1 CreateIoCompletionPort dup win32-error=0/f ;
|
||||
|
|
@ -28,8 +29,8 @@ SYMBOL: master-completion-port
|
|||
: <master-completion-port> ( -- handle )
|
||||
INVALID_HANDLE_VALUE f <completion-port> ;
|
||||
|
||||
M: winnt add-completion ( handle -- )
|
||||
master-completion-port get-global <completion-port> drop ;
|
||||
M: winnt add-completion ( win32-handle -- )
|
||||
handle>> master-completion-port get-global <completion-port> drop ;
|
||||
|
||||
: eof? ( error -- ? )
|
||||
dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ;
|
||||
|
|
@ -56,13 +57,21 @@ M: winnt add-completion ( handle -- )
|
|||
io-hash get-global set-at
|
||||
] "I/O" suspend 3drop ;
|
||||
|
||||
: wait-for-overlapped ( ms -- overlapped ? )
|
||||
>r master-completion-port get-global
|
||||
r> INFINITE or ! timeout
|
||||
: twiddle-thumbs ( overlapped port -- bytes-transferred )
|
||||
[ save-callback ]
|
||||
[ get-overlapped-result ]
|
||||
[ nip pending-error ]
|
||||
2tri ;
|
||||
|
||||
:: wait-for-overlapped ( ms -- overlapped ? )
|
||||
master-completion-port get-global
|
||||
0 <int> ! bytes
|
||||
f <void*> ! key
|
||||
f <void*> ! overlapped
|
||||
[ roll GetQueuedCompletionStatus ] keep *void* swap zero? ;
|
||||
[
|
||||
ms INFINITE or ! timeout
|
||||
GetQueuedCompletionStatus
|
||||
] keep *void* swap zero? ;
|
||||
|
||||
: lookup-callback ( overlapped -- callback )
|
||||
io-hash get-global delete-at* drop
|
||||
|
|
@ -70,32 +79,64 @@ M: winnt add-completion ( handle -- )
|
|||
|
||||
: handle-overlapped ( timeout -- ? )
|
||||
wait-for-overlapped [
|
||||
GetLastError dup expected-io-error? [
|
||||
2drop t
|
||||
] [
|
||||
dup eof? [
|
||||
drop lookup-callback
|
||||
dup port>> t >>eof drop
|
||||
] [
|
||||
(win32-error-string) swap lookup-callback
|
||||
[ port>> set-port-error ] keep
|
||||
] if thread>> resume f
|
||||
GetLastError dup expected-io-error? [ 2drop f ] [
|
||||
>r lookup-callback [ thread>> ] [ port>> ] bi r>
|
||||
dup eof?
|
||||
[ drop t >>eof ]
|
||||
[ (win32-error-string) >>error ] if drop
|
||||
resume t
|
||||
] if
|
||||
] [
|
||||
lookup-callback
|
||||
io-callback-thread resume f
|
||||
thread>> resume t
|
||||
] if ;
|
||||
|
||||
: drain-overlapped ( timeout -- )
|
||||
handle-overlapped [ 0 drain-overlapped ] unless ;
|
||||
|
||||
M: winnt cancel-io
|
||||
handle>> handle>> CancelIo drop ;
|
||||
|
||||
M: winnt io-multiplex ( ms -- )
|
||||
drain-overlapped ;
|
||||
handle-overlapped [ 0 io-multiplex ] when ;
|
||||
|
||||
M: winnt init-io ( -- )
|
||||
<master-completion-port> master-completion-port set-global
|
||||
H{ } clone io-hash set-global
|
||||
windows.winsock:init-winsock ;
|
||||
|
||||
: 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 ] 2bi
|
||||
] 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 ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: continuations destructors io.buffers io.files io.backend
|
||||
io.timeouts io.ports io.windows io.windows.nt.backend
|
||||
kernel libc math threads windows windows.kernel32 system
|
||||
io.timeouts io.ports io.windows io.windows.files
|
||||
io.windows.nt.backend windows windows.kernel32
|
||||
kernel libc math threads system
|
||||
alien.c-types alien.arrays alien.strings sequences combinators
|
||||
combinators.lib sequences.lib ascii splitting alien strings
|
||||
assocs namespaces io.files.private accessors ;
|
||||
|
|
@ -29,6 +30,7 @@ M: winnt root-directory? ( path -- ? )
|
|||
} cond nip ;
|
||||
|
||||
ERROR: not-absolute-path ;
|
||||
|
||||
: root-directory ( string -- string' )
|
||||
{
|
||||
[ dup length 2 >= ]
|
||||
|
|
@ -54,57 +56,4 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
|
|||
|
||||
M: winnt open-append
|
||||
[ dup file-info size>> ] [ drop 0 ] recover
|
||||
>r (open-append) r> ;
|
||||
|
||||
: update-file-ptr ( n port -- )
|
||||
port-handle
|
||||
dup win32-file-ptr [
|
||||
rot + swap set-win32-file-ptr
|
||||
] [
|
||||
2drop
|
||||
] if* ;
|
||||
|
||||
: finish-flush ( overlapped port -- )
|
||||
dup pending-error
|
||||
tuck get-overlapped-result
|
||||
dup pick update-file-ptr
|
||||
swap buffer>> buffer-consume ;
|
||||
|
||||
: (flush-output) ( port -- )
|
||||
dup make-FileArgs
|
||||
tuck setup-write WriteFile
|
||||
dupd overlapped-error? [
|
||||
>r FileArgs-lpOverlapped r>
|
||||
[ save-callback ] 2keep
|
||||
[ finish-flush ] keep
|
||||
dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: flush-output ( port -- )
|
||||
[ [ (flush-output) ] with-timeout ] with-destructors ;
|
||||
|
||||
M: winnt flush-port
|
||||
dup buffer>> buffer-empty? [ dup flush-output ] unless drop ;
|
||||
|
||||
: finish-read ( overlapped port -- )
|
||||
dup pending-error
|
||||
tuck get-overlapped-result dup zero? [
|
||||
drop t >>eof drop
|
||||
] [
|
||||
dup pick buffer>> n>buffer
|
||||
swap update-file-ptr
|
||||
] if ;
|
||||
|
||||
: ((wait-to-read)) ( port -- )
|
||||
dup make-FileArgs
|
||||
tuck setup-read ReadFile
|
||||
dupd overlapped-error? [
|
||||
>r FileArgs-lpOverlapped r>
|
||||
[ save-callback ] 2keep
|
||||
finish-read
|
||||
] [ 2drop ] if ;
|
||||
|
||||
M: winnt (wait-to-read) ( port -- )
|
||||
[ [ ((wait-to-read)) ] with-timeout ] with-destructors ;
|
||||
>r (open-append) r> >>ptr ;
|
||||
|
|
|
|||
|
|
@ -4,8 +4,9 @@ USING: alien alien.c-types arrays continuations destructors io
|
|||
io.windows libc io.ports io.pipes windows.types
|
||||
math windows.kernel32 windows namespaces io.launcher kernel
|
||||
sequences windows.errors assocs splitting system strings
|
||||
io.windows.launcher io.windows.nt.pipes io.backend io.files
|
||||
io.files.private combinators shuffle accessors locals ;
|
||||
io.windows.launcher io.windows.files
|
||||
io.backend io.files io.files.private combinators shuffle
|
||||
accessors locals ;
|
||||
IN: io.windows.nt.launcher
|
||||
|
||||
: duplicate-handle ( handle -- handle' )
|
||||
|
|
@ -21,10 +22,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 )
|
||||
{
|
||||
|
|
@ -35,13 +36,13 @@ IN: io.windows.nt.launcher
|
|||
! The below code is based on the example given in
|
||||
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
|
||||
|
||||
: redirect-default ( default obj access-mode create-mode -- handle )
|
||||
3drop ;
|
||||
: redirect-default ( obj access-mode create-mode -- handle )
|
||||
3drop f ;
|
||||
|
||||
: redirect-closed ( default obj access-mode create-mode -- handle )
|
||||
drop 2nip null-pipe ;
|
||||
: redirect-closed ( obj access-mode create-mode -- handle )
|
||||
drop nip null-pipe ;
|
||||
|
||||
:: redirect-file ( default path access-mode create-mode -- handle )
|
||||
:: redirect-file ( path access-mode create-mode -- handle )
|
||||
path normalize-path
|
||||
access-mode
|
||||
share-mode
|
||||
|
|
@ -49,9 +50,9 @@ IN: io.windows.nt.launcher
|
|||
create-mode
|
||||
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
||||
f ! template file
|
||||
CreateFile dup invalid-handle? dup close-always ;
|
||||
CreateFile dup invalid-handle? <win32-file> &dispose handle>> ;
|
||||
|
||||
: redirect-append ( default path access-mode create-mode -- handle )
|
||||
: redirect-append ( path access-mode create-mode -- handle )
|
||||
>r >r path>> r> r>
|
||||
drop OPEN_ALWAYS
|
||||
redirect-file
|
||||
|
|
@ -60,14 +61,13 @@ IN: io.windows.nt.launcher
|
|||
: set-inherit ( handle ? -- )
|
||||
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
|
||||
|
||||
: redirect-handle ( default handle access-mode create-mode -- handle )
|
||||
2drop nip
|
||||
handle>> duplicate-handle dup t set-inherit ;
|
||||
: redirect-handle ( handle access-mode create-mode -- handle )
|
||||
2drop handle>> duplicate-handle dup t set-inherit ;
|
||||
|
||||
: redirect-stream ( default stream access-mode create-mode -- handle )
|
||||
>r >r underlying-handle r> r> redirect-handle ;
|
||||
: redirect-stream ( stream access-mode create-mode -- handle )
|
||||
>r >r underlying-handle handle>> r> r> redirect-handle ;
|
||||
|
||||
: redirect ( default obj access-mode create-mode -- handle )
|
||||
: redirect ( obj access-mode create-mode -- handle )
|
||||
{
|
||||
{ [ pick not ] [ redirect-default ] }
|
||||
{ [ pick +closed+ eq? ] [ redirect-closed ] }
|
||||
|
|
@ -77,12 +77,9 @@ 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>>
|
||||
drop
|
||||
stdout>>
|
||||
GENERIC_WRITE
|
||||
CREATE_ALWAYS
|
||||
redirect
|
||||
|
|
@ -90,25 +87,20 @@ IN: io.windows.nt.launcher
|
|||
|
||||
: redirect-stderr ( process args -- handle )
|
||||
over stderr>> +stdout+ eq? [
|
||||
lpStartupInfo>>
|
||||
STARTUPINFO-hStdOutput
|
||||
nip
|
||||
lpStartupInfo>> STARTUPINFO-hStdOutput
|
||||
] [
|
||||
drop
|
||||
f
|
||||
swap stderr>>
|
||||
stderr>>
|
||||
GENERIC_WRITE
|
||||
CREATE_ALWAYS
|
||||
redirect
|
||||
STD_ERROR_HANDLE GetStdHandle or
|
||||
] if ;
|
||||
|
||||
: default-stdin ( args -- handle )
|
||||
stdin-pipe>> dup [ in>> ] when ;
|
||||
|
||||
: redirect-stdin ( process args -- handle )
|
||||
default-stdin
|
||||
swap stdin>>
|
||||
drop
|
||||
stdin>>
|
||||
GENERIC_READ
|
||||
OPEN_EXISTING
|
||||
redirect
|
||||
|
|
|
|||
|
|
@ -17,11 +17,7 @@ IN: io.windows.nt.monitors
|
|||
OPEN_EXISTING
|
||||
{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
|
||||
f
|
||||
CreateFile
|
||||
dup invalid-handle?
|
||||
dup close-later
|
||||
dup add-completion
|
||||
f <win32-file> ;
|
||||
CreateFile opened-file ;
|
||||
|
||||
TUPLE: win32-monitor-port < input-port recursive ;
|
||||
|
||||
|
|
@ -41,11 +37,7 @@ TUPLE: win32-monitor < monitor port ;
|
|||
|
||||
: read-changes ( port -- bytes )
|
||||
[
|
||||
dup begin-reading-changes
|
||||
swap [ save-callback ] 2keep
|
||||
check-closed ! we may have closed it...
|
||||
dup eof>> [ "EOF??" throw ] when
|
||||
get-overlapped-result
|
||||
[ begin-reading-changes ] [ twiddle-thumbs ] bi
|
||||
] with-destructors ;
|
||||
|
||||
: parse-action ( action -- changed )
|
||||
|
|
@ -87,7 +79,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 ;
|
||||
|
|
@ -97,7 +89,7 @@ TUPLE: win32-monitor < monitor port ;
|
|||
|
||||
: fill-queue-thread ( monitor -- )
|
||||
[ dup fill-queue (fill-queue-thread) ]
|
||||
[ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ;
|
||||
[ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ;
|
||||
|
||||
M:: winnt (monitor) ( path recursive? mailbox -- monitor )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ USE: io.windows.nt.backend
|
|||
USE: io.windows.nt.files
|
||||
USE: io.windows.nt.launcher
|
||||
USE: io.windows.nt.monitors
|
||||
USE: io.windows.nt.privileges
|
||||
USE: io.windows.nt.sockets
|
||||
USE: io.windows.mmap
|
||||
USE: io.windows.files
|
||||
|
|
|
|||
|
|
@ -17,10 +17,7 @@ IN: io.windows.nt.pipes
|
|||
4096
|
||||
0
|
||||
security-attributes-inherit
|
||||
CreateNamedPipe
|
||||
dup win32-error=0/f
|
||||
dup add-completion
|
||||
f <win32-file> ;
|
||||
CreateNamedPipe opened-file ;
|
||||
|
||||
: open-other-end ( name -- handle )
|
||||
GENERIC_WRITE
|
||||
|
|
@ -29,10 +26,7 @@ IN: io.windows.nt.pipes
|
|||
OPEN_EXISTING
|
||||
FILE_FLAG_OVERLAPPED
|
||||
f
|
||||
CreateFile
|
||||
dup win32-error=0/f
|
||||
dup add-completion
|
||||
f <win32-file> ;
|
||||
CreateFile opened-file ;
|
||||
|
||||
: unique-pipe-name ( -- string )
|
||||
[
|
||||
|
|
@ -47,7 +41,6 @@ IN: io.windows.nt.pipes
|
|||
M: winnt (pipe) ( -- pipe )
|
||||
[
|
||||
unique-pipe-name
|
||||
[ create-named-pipe dup close-later ]
|
||||
[ open-other-end dup close-later ]
|
||||
bi pipe boa
|
||||
[ create-named-pipe ] [ open-other-end ] bi
|
||||
pipe boa
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,53 @@
|
|||
USING: alien alien.c-types alien.syntax arrays continuations
|
||||
destructors generic io.mmap io.ports io.windows io.windows.files
|
||||
kernel libc math math.bitfields namespaces quotations sequences windows
|
||||
windows.advapi32 windows.kernel32 io.backend system accessors
|
||||
io.windows.privileges ;
|
||||
IN: io.windows.nt.privileges
|
||||
|
||||
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
||||
|
||||
! Security tokens
|
||||
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
|
||||
|
||||
: (open-process-token) ( handle -- handle )
|
||||
{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>
|
||||
[ OpenProcessToken win32-error=0/f ] keep *void* ;
|
||||
|
||||
: open-process-token ( -- handle )
|
||||
#! remember to CloseHandle
|
||||
GetCurrentProcess (open-process-token) ;
|
||||
|
||||
: with-process-token ( quot -- )
|
||||
#! quot: ( token-handle -- token-handle )
|
||||
>r open-process-token r>
|
||||
[ keep ] curry
|
||||
[ CloseHandle drop ] [ ] cleanup ; inline
|
||||
|
||||
: lookup-privilege ( string -- luid )
|
||||
>r f r> "LUID" <c-object>
|
||||
[ LookupPrivilegeValue win32-error=0/f ] keep ;
|
||||
|
||||
: make-token-privileges ( name ? -- obj )
|
||||
"TOKEN_PRIVILEGES" <c-object>
|
||||
1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep
|
||||
"LUID_AND_ATTRIBUTES" malloc-array &free
|
||||
over set-TOKEN_PRIVILEGES-Privileges
|
||||
|
||||
swap [
|
||||
SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
|
||||
set-LUID_AND_ATTRIBUTES-Attributes
|
||||
] when
|
||||
|
||||
>r lookup-privilege r>
|
||||
[
|
||||
TOKEN_PRIVILEGES-Privileges
|
||||
>r 0 r> LUID_AND_ATTRIBUTES-nth
|
||||
set-LUID_AND_ATTRIBUTES-Luid
|
||||
] keep ;
|
||||
|
||||
M: winnt set-privilege ( name ? -- )
|
||||
[
|
||||
-rot 0 -rot make-token-privileges
|
||||
dup length f f AdjustTokenPrivileges win32-error=0/f
|
||||
] with-process-token ;
|
||||
|
|
@ -1,8 +1,9 @@
|
|||
USING: alien alien.accessors alien.c-types byte-arrays
|
||||
continuations destructors io.ports io.timeouts io.sockets
|
||||
io.sockets io namespaces io.streams.duplex io.windows
|
||||
io.windows.sockets
|
||||
io.windows.nt.backend windows.winsock kernel libc math sequences
|
||||
threads classes.tuple.lib system accessors ;
|
||||
threads classes.tuple.lib system combinators accessors ;
|
||||
IN: io.windows.nt.sockets
|
||||
|
||||
: malloc-int ( object -- object )
|
||||
|
|
@ -30,121 +31,68 @@ TUPLE: ConnectEx-args port
|
|||
s* name* namelen* lpSendBuffer* dwSendDataLength*
|
||||
lpdwBytesSent* lpOverlapped* ptr* ;
|
||||
|
||||
: init-connect ( sockaddr size ConnectEx -- )
|
||||
[ set-ConnectEx-args-namelen* ] keep
|
||||
[ set-ConnectEx-args-name* ] keep
|
||||
f over set-ConnectEx-args-lpSendBuffer*
|
||||
0 over set-ConnectEx-args-dwSendDataLength*
|
||||
f over set-ConnectEx-args-lpdwBytesSent*
|
||||
(make-overlapped) swap set-ConnectEx-args-lpOverlapped* ;
|
||||
: wait-for-socket ( args -- n )
|
||||
[ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
|
||||
|
||||
: (ConnectEx) ( ConnectEx -- )
|
||||
\ ConnectEx-args >tuple*<
|
||||
: <ConnectEx-args> ( sockaddr size -- ConnectEx )
|
||||
ConnectEx-args new
|
||||
swap >>namelen*
|
||||
swap >>name*
|
||||
f >>lpSendBuffer*
|
||||
0 >>dwSendDataLength*
|
||||
f >>lpdwBytesSent*
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
|
||||
: call-ConnectEx ( ConnectEx -- )
|
||||
ConnectEx-args >tuple*<
|
||||
"int"
|
||||
{ "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
|
||||
"stdcall" alien-indirect drop
|
||||
winsock-error-string [ throw ] when* ;
|
||||
|
||||
: connect-continuation ( overlapped port -- )
|
||||
2dup save-callback
|
||||
get-overlapped-result drop ;
|
||||
|
||||
M: win32-socket wait-to-connect ( client-out handle -- )
|
||||
[ overlapped>> swap connect-continuation ]
|
||||
[ drop pending-error ]
|
||||
2bi ;
|
||||
|
||||
M: object ((client)) ( addrspec -- handle )
|
||||
[
|
||||
\ ConnectEx-args new
|
||||
over make-sockaddr/size pick init-connect
|
||||
over tcp-socket over set-ConnectEx-args-s*
|
||||
dup ConnectEx-args-s* add-completion
|
||||
dup ConnectEx-args-s* get-ConnectEx-ptr over set-ConnectEx-args-ptr*
|
||||
dup ConnectEx-args-s* INADDR_ANY roll bind-socket
|
||||
dup (ConnectEx)
|
||||
|
||||
dup [ ConnectEx-args-s* ] [ ConnectEx-args-lpOverlapped* ] bi <win32-socket>
|
||||
] with-destructors ;
|
||||
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*
|
||||
dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ;
|
||||
|
||||
: init-accept-buffer ( server-port AcceptEx -- )
|
||||
>r server-port-addr sockaddr-type heap-size 16 +
|
||||
dup dup 2 * malloc dup free-always r>
|
||||
[ set-AcceptEx-args-lpOutputBuffer* ] keep
|
||||
[ set-AcceptEx-args-dwLocalAddressLength* ] keep
|
||||
set-AcceptEx-args-dwRemoteAddressLength* ;
|
||||
: init-accept-buffer ( addr AcceptEx -- )
|
||||
swap sockaddr-type heap-size 16 +
|
||||
[ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi
|
||||
dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer*
|
||||
drop ;
|
||||
|
||||
: init-accept ( server-port AcceptEx -- )
|
||||
[ init-accept-buffer ] 2keep
|
||||
[ set-AcceptEx-args-port ] 2keep
|
||||
>r port-handle win32-file-handle r> [ set-AcceptEx-args-sListenSocket* ] keep
|
||||
dup AcceptEx-args-port server-port-addr tcp-socket
|
||||
over set-AcceptEx-args-sAcceptSocket*
|
||||
0 over set-AcceptEx-args-dwReceiveDataLength*
|
||||
f over set-AcceptEx-args-lpdwBytesReceived*
|
||||
(make-overlapped) swap set-AcceptEx-args-lpOverlapped* ;
|
||||
: <AcceptEx-args> ( server addr -- AcceptEx )
|
||||
AcceptEx-args new
|
||||
2dup init-accept-buffer
|
||||
swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket*
|
||||
over handle>> handle>> >>sListenSocket*
|
||||
swap >>port
|
||||
0 >>dwReceiveDataLength*
|
||||
f >>lpdwBytesReceived*
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
|
||||
: ((accept)) ( AcceptEx -- )
|
||||
\ AcceptEx-args >tuple*<
|
||||
AcceptEx drop
|
||||
: call-AcceptEx ( AcceptEx -- )
|
||||
AcceptEx-args >tuple*< AcceptEx drop
|
||||
winsock-error-string [ throw ] when* ;
|
||||
|
||||
: make-accept-continuation ( AcceptEx -- )
|
||||
dup AcceptEx-args-lpOverlapped*
|
||||
swap AcceptEx-args-port save-callback ;
|
||||
|
||||
: check-accept-error ( AcceptEx -- )
|
||||
dup AcceptEx-args-lpOverlapped*
|
||||
swap AcceptEx-args-port get-overlapped-result drop ;
|
||||
|
||||
: extract-remote-host ( AcceptEx -- addrspec )
|
||||
[
|
||||
[ AcceptEx-args-lpOutputBuffer* ] keep
|
||||
[ AcceptEx-args-dwReceiveDataLength* ] keep
|
||||
[ AcceptEx-args-dwLocalAddressLength* ] keep
|
||||
AcceptEx-args-dwRemoteAddressLength*
|
||||
f <void*>
|
||||
0 <int>
|
||||
f <void*> [
|
||||
0 <int> GetAcceptExSockaddrs
|
||||
] keep *void*
|
||||
] keep AcceptEx-args-port server-port-addr parse-sockaddr ;
|
||||
|
||||
: accept-continuation ( AcceptEx -- addrspec client )
|
||||
[ make-accept-continuation ] keep
|
||||
[ check-accept-error ] keep
|
||||
[ extract-remote-host ] keep
|
||||
! addrspec AcceptEx
|
||||
[ AcceptEx-args-sAcceptSocket* add-completion ] keep
|
||||
[ AcceptEx-args-sAcceptSocket* ] [ AcceptEx-args-lpOverlapped* ] bi <win32-socket> ;
|
||||
|
||||
M: winnt (accept) ( server -- addrspec handle )
|
||||
M: object (accept) ( server addr -- handle )
|
||||
[
|
||||
[
|
||||
\ AcceptEx-args new
|
||||
[ init-accept ] keep
|
||||
[ ((accept)) ] keep
|
||||
[ accept-continuation ] keep
|
||||
AcceptEx-args-port pending-error
|
||||
] with-timeout
|
||||
] with-destructors ;
|
||||
|
||||
M: winnt (server) ( addrspec -- handle )
|
||||
[
|
||||
SOCK_STREAM server-fd dup listen-on-socket
|
||||
dup add-completion
|
||||
f <win32-socket>
|
||||
] with-destructors ;
|
||||
|
||||
M: winnt (datagram) ( addrspec -- handle )
|
||||
[
|
||||
SOCK_DGRAM server-fd
|
||||
dup add-completion
|
||||
f <win32-socket>
|
||||
<AcceptEx-args>
|
||||
{
|
||||
[ call-AcceptEx ]
|
||||
[ wait-for-socket drop ]
|
||||
[ sAcceptSocket*>> opened-socket ]
|
||||
[ port>> pending-error ]
|
||||
} cleave
|
||||
] curry with-timeout
|
||||
] with-destructors ;
|
||||
|
||||
TUPLE: WSARecvFrom-args port
|
||||
|
|
@ -152,53 +100,38 @@ TUPLE: WSARecvFrom-args port
|
|||
lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ;
|
||||
|
||||
: make-receive-buffer ( -- WSABUF )
|
||||
"WSABUF" malloc-object dup free-always
|
||||
"WSABUF" malloc-object &free
|
||||
default-buffer-size get over set-WSABUF-len
|
||||
default-buffer-size get malloc dup free-always over set-WSABUF-buf ;
|
||||
default-buffer-size get malloc &free over set-WSABUF-buf ;
|
||||
|
||||
: init-WSARecvFrom ( datagram WSARecvFrom -- )
|
||||
[ set-WSARecvFrom-args-port ] 2keep
|
||||
[
|
||||
>r handle>> handle>> r>
|
||||
set-WSARecvFrom-args-s*
|
||||
] 2keep [
|
||||
>r datagram-port-addr sockaddr-type heap-size r>
|
||||
2dup >r malloc dup free-always r> set-WSARecvFrom-args-lpFrom*
|
||||
>r malloc-int dup free-always r> set-WSARecvFrom-args-lpFromLen*
|
||||
] keep
|
||||
make-receive-buffer over set-WSARecvFrom-args-lpBuffers*
|
||||
1 over set-WSARecvFrom-args-dwBufferCount*
|
||||
0 malloc-int dup free-always over set-WSARecvFrom-args-lpFlags*
|
||||
0 malloc-int dup free-always over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
|
||||
(make-overlapped) swap set-WSARecvFrom-args-lpOverlapped* ;
|
||||
|
||||
: WSARecvFrom-continuation ( WSARecvFrom -- n )
|
||||
dup WSARecvFrom-args-lpOverlapped*
|
||||
swap WSARecvFrom-args-port [ save-callback ] 2keep
|
||||
get-overlapped-result ;
|
||||
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
|
||||
WSARecvFrom-args new
|
||||
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*
|
||||
1 >>dwBufferCount*
|
||||
0 malloc-int &free >>lpFlags*
|
||||
0 malloc-int &free >>lpNumberOfBytesRecvd*
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
|
||||
: call-WSARecvFrom ( WSARecvFrom -- )
|
||||
\ WSARecvFrom-args >tuple*<
|
||||
WSARecvFrom
|
||||
socket-error* ;
|
||||
WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
|
||||
|
||||
: parse-WSARecvFrom ( n WSARecvFrom -- packet addrspec )
|
||||
[
|
||||
WSARecvFrom-args-lpBuffers* WSABUF-buf
|
||||
swap memory>byte-array
|
||||
] keep
|
||||
[ WSARecvFrom-args-lpFrom* ] keep
|
||||
WSARecvFrom-args-port datagram-port-addr parse-sockaddr ;
|
||||
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
|
||||
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ;
|
||||
|
||||
M: winnt receive ( datagram -- packet addrspec )
|
||||
M: winnt (receive) ( datagram -- packet addrspec )
|
||||
[
|
||||
check-datagram-port
|
||||
\ WSARecvFrom-args new
|
||||
[ init-WSARecvFrom ] keep
|
||||
[ call-WSARecvFrom ] keep
|
||||
[ WSARecvFrom-continuation ] keep
|
||||
[ WSARecvFrom-args-port pending-error ] keep
|
||||
parse-WSARecvFrom
|
||||
<WSARecvFrom-args>
|
||||
{
|
||||
[ call-WSARecvFrom ]
|
||||
[ wait-for-socket ]
|
||||
[ port>> pending-error ]
|
||||
[ parse-WSARecvFrom ]
|
||||
} cleave
|
||||
] with-destructors ;
|
||||
|
||||
TUPLE: WSASendTo-args port
|
||||
|
|
@ -206,49 +139,33 @@ TUPLE: WSASendTo-args port
|
|||
dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ;
|
||||
|
||||
: make-send-buffer ( packet -- WSABUF )
|
||||
"WSABUF" malloc-object dup free-always
|
||||
over malloc-byte-array dup free-always over set-WSABUF-buf
|
||||
swap length over set-WSABUF-len ;
|
||||
"WSABUF" malloc-object &free
|
||||
[ >r malloc-byte-array &free r> set-WSABUF-buf ]
|
||||
[ >r length r> set-WSABUF-len ]
|
||||
[ nip ]
|
||||
2tri ;
|
||||
|
||||
: init-WSASendTo ( packet addrspec datagram WSASendTo -- )
|
||||
[ set-WSASendTo-args-port ] 2keep
|
||||
[
|
||||
>r port-handle win32-file-handle r> set-WSASendTo-args-s*
|
||||
] keep
|
||||
[
|
||||
>r make-sockaddr/size >r
|
||||
malloc-byte-array dup free-always
|
||||
r> r>
|
||||
[ set-WSASendTo-args-iToLen* ] keep
|
||||
set-WSASendTo-args-lpTo*
|
||||
] keep
|
||||
[
|
||||
>r make-send-buffer r> set-WSASendTo-args-lpBuffers*
|
||||
] keep
|
||||
1 over set-WSASendTo-args-dwBufferCount*
|
||||
0 over set-WSASendTo-args-dwFlags*
|
||||
0 <uint> over set-WSASendTo-args-lpNumberOfBytesSent*
|
||||
(make-overlapped) swap set-WSASendTo-args-lpOverlapped* ;
|
||||
|
||||
: WSASendTo-continuation ( WSASendTo -- )
|
||||
dup WSASendTo-args-lpOverlapped*
|
||||
swap WSASendTo-args-port
|
||||
[ save-callback ] 2keep
|
||||
get-overlapped-result drop ;
|
||||
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
|
||||
WSASendTo-args new
|
||||
swap >>port
|
||||
dup port>> handle>> handle>> >>s*
|
||||
swap make-sockaddr/size
|
||||
>r malloc-byte-array &free
|
||||
r> [ >>lpTo* ] [ >>iToLen* ] bi*
|
||||
swap make-send-buffer >>lpBuffers*
|
||||
1 >>dwBufferCount*
|
||||
0 >>dwFlags*
|
||||
0 <uint> >>lpNumberOfBytesSent*
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
|
||||
: call-WSASendTo ( WSASendTo -- )
|
||||
\ WSASendTo-args >tuple*<
|
||||
WSASendTo socket-error* ;
|
||||
WSASendTo-args >tuple*< WSASendTo socket-error* ;
|
||||
|
||||
USE: io.sockets
|
||||
|
||||
M: winnt send ( packet addrspec datagram -- )
|
||||
M: winnt (send) ( packet addrspec datagram -- )
|
||||
[
|
||||
check-datagram-send
|
||||
\ WSASendTo-args new
|
||||
[ init-WSASendTo ] keep
|
||||
[ call-WSASendTo ] keep
|
||||
[ WSASendTo-continuation ] keep
|
||||
WSASendTo-args-port pending-error
|
||||
<WSASendTo-args>
|
||||
[ call-WSASendTo ]
|
||||
[ wait-for-socket drop ]
|
||||
[ port>> pending-error ]
|
||||
tri
|
||||
] with-destructors ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,8 @@
|
|||
USING: io.backend kernel continuations sequences ;
|
||||
IN: io.windows.privileges
|
||||
|
||||
HOOK: set-privilege io-backend ( name ? -- ) inline
|
||||
|
||||
: with-privileges ( seq quot -- )
|
||||
over [ [ t set-privilege ] each ] curry compose
|
||||
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
USING: kernel accessors io.sockets io.windows io.backend
|
||||
windows.winsock system destructors alien.c-types ;
|
||||
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 ;
|
||||
|
||||
: opened-socket ( handle -- win32-socket )
|
||||
<win32-socket> |dispose dup add-completion ;
|
||||
|
||||
: open-socket ( addrspec type -- win32-socket )
|
||||
>r protocol-family r>
|
||||
0 f 0 WSASocket-flags WSASocket
|
||||
dup socket-error
|
||||
opened-socket ;
|
||||
|
||||
M: object (get-local-address) ( socket addrspec -- sockaddr )
|
||||
>r handle>> r> empty-sockaddr/size <int>
|
||||
[ getsockname socket-error ] 2keep drop ;
|
||||
|
||||
: bind-socket ( win32-socket sockaddr len -- )
|
||||
>r >r handle>> r> r> bind socket-error ;
|
||||
|
||||
M: object ((client)) ( addrspec -- handle )
|
||||
[ SOCK_STREAM open-socket ] keep
|
||||
[ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ;
|
||||
|
||||
: server-socket ( addrspec type -- fd )
|
||||
[ open-socket ] [ drop ] 2bi
|
||||
[ make-sockaddr/size bind-socket ] [ 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 ;
|
||||
|
|
@ -8,18 +8,33 @@ windows.shell32 windows.types windows.winsock splitting
|
|||
continuations math.bitfields system accessors ;
|
||||
IN: io.windows
|
||||
|
||||
M: windows destruct-socket closesocket drop ;
|
||||
TUPLE: win32-handle handle disposed ;
|
||||
|
||||
TUPLE: win32-file handle ptr ;
|
||||
: new-win32-handle ( handle class -- win32-handle )
|
||||
new swap >>handle ;
|
||||
|
||||
C: <win32-file> win32-file
|
||||
: <win32-handle> ( handle -- win32-handle )
|
||||
win32-handle new-win32-handle ;
|
||||
|
||||
M: win32-handle dispose* ( handle -- )
|
||||
handle>> CloseHandle drop ;
|
||||
|
||||
TUPLE: win32-file < win32-handle ptr ;
|
||||
|
||||
: <win32-file> ( handle -- win32-file )
|
||||
win32-file new-win32-handle ;
|
||||
|
||||
M: win32-file init-handle ( handle -- )
|
||||
drop ;
|
||||
|
||||
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
|
||||
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
|
||||
HOOK: add-completion io-backend ( port -- )
|
||||
|
||||
M: windows normalize-directory ( string -- string )
|
||||
normalize-path "\\" ?tail drop "\\*" append ;
|
||||
: opened-file ( handle -- win32-file )
|
||||
dup invalid-handle?
|
||||
<win32-file> |dispose
|
||||
dup add-completion ;
|
||||
|
||||
: share-mode ( -- fixnum )
|
||||
{
|
||||
|
|
@ -36,176 +51,3 @@ M: windows normalize-directory ( string -- string )
|
|||
: security-attributes-inherit ( -- obj )
|
||||
default-security-attributes
|
||||
TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable
|
||||
|
||||
M: win32-file init-handle ( handle -- )
|
||||
drop ;
|
||||
|
||||
M: win32-file close-handle ( handle -- )
|
||||
win32-file-handle close-handle ;
|
||||
|
||||
M: alien close-handle ( handle -- )
|
||||
CloseHandle drop ;
|
||||
|
||||
! Clean up resources (open handle) if add-completion fails
|
||||
: 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? dup close-later
|
||||
dup add-completion
|
||||
] with-destructors ;
|
||||
|
||||
: open-pipe-r/w ( path -- handle )
|
||||
{ GENERIC_READ GENERIC_WRITE } flags
|
||||
OPEN_EXISTING 0 open-file ;
|
||||
|
||||
: open-read ( path -- handle length )
|
||||
GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
|
||||
|
||||
: open-write ( path -- handle length )
|
||||
GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 ;
|
||||
|
||||
: (open-append) ( path -- handle )
|
||||
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
|
||||
|
||||
: open-existing ( path -- handle )
|
||||
{ GENERIC_READ GENERIC_WRITE } flags
|
||||
share-mode
|
||||
f
|
||||
OPEN_EXISTING
|
||||
FILE_FLAG_BACKUP_SEMANTICS
|
||||
f CreateFileW dup win32-error=0/f ;
|
||||
|
||||
: maybe-create-file ( path -- handle ? )
|
||||
#! 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
|
||||
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 -- handle length )
|
||||
|
||||
TUPLE: FileArgs
|
||||
hFile lpBuffer nNumberOfBytesToRead
|
||||
lpNumberOfBytesRet lpOverlapped ;
|
||||
|
||||
C: <FileArgs> FileArgs
|
||||
|
||||
: make-FileArgs ( port -- <FileArgs> )
|
||||
[ port-handle win32-file-handle ] keep
|
||||
[ buffer>> ] keep
|
||||
[
|
||||
buffer>> buffer-length
|
||||
"DWORD" <c-object>
|
||||
] keep FileArgs-overlapped <FileArgs> ;
|
||||
|
||||
: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
|
||||
[ FileArgs-hFile ] keep
|
||||
[ FileArgs-lpBuffer buffer-end ] keep
|
||||
[ FileArgs-lpBuffer buffer-capacity ] keep
|
||||
[ FileArgs-lpNumberOfBytesRet ] keep
|
||||
FileArgs-lpOverlapped ;
|
||||
|
||||
: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
|
||||
[ FileArgs-hFile ] keep
|
||||
[ FileArgs-lpBuffer buffer@ ] keep
|
||||
[ FileArgs-lpBuffer buffer-length ] keep
|
||||
[ FileArgs-lpNumberOfBytesRet ] keep
|
||||
FileArgs-lpOverlapped ;
|
||||
|
||||
M: windows (file-reader) ( path -- stream )
|
||||
open-read <win32-file> <input-port> ;
|
||||
|
||||
M: windows (file-writer) ( path -- stream )
|
||||
open-write <win32-file> <output-port> ;
|
||||
|
||||
M: windows (file-appender) ( path -- stream )
|
||||
open-append <win32-file> <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 ;
|
||||
|
||||
HOOK: WSASocket-flags io-backend ( -- DWORD )
|
||||
|
||||
TUPLE: win32-socket < win32-file overlapped ;
|
||||
|
||||
: <win32-socket> ( handle overlapped -- win32-socket )
|
||||
win32-socket new
|
||||
swap >>overlapped
|
||||
swap >>handle ;
|
||||
|
||||
: open-socket ( family type -- socket )
|
||||
0 f 0 WSASocket-flags WSASocket dup socket-error ;
|
||||
|
||||
USE: windows.winsock
|
||||
: init-sockaddr ( port# addrspec -- sockaddr )
|
||||
dup sockaddr-type <c-object>
|
||||
[ swap protocol-family swap set-sockaddr-in-family ] keep
|
||||
[ >r htons r> set-sockaddr-in-port ] keep ;
|
||||
|
||||
: server-sockaddr ( port# addrspec -- sockaddr )
|
||||
init-sockaddr
|
||||
[ INADDR_ANY swap set-sockaddr-in-addr ] keep ;
|
||||
|
||||
: bind-socket ( socket sockaddr addrspec -- )
|
||||
[ server-sockaddr ] keep
|
||||
sockaddr-type heap-size bind socket-error ;
|
||||
|
||||
TUPLE: socket-destructor alien ;
|
||||
|
||||
C: <socket-destructor> socket-destructor
|
||||
|
||||
HOOK: destruct-socket io-backend ( obj -- )
|
||||
|
||||
M: socket-destructor dispose ( obj -- )
|
||||
alien>> destruct-socket ;
|
||||
|
||||
: close-socket-later ( handle -- )
|
||||
<socket-destructor> <only-once> |dispose drop ;
|
||||
|
||||
: server-fd ( addrspec type -- fd )
|
||||
>r dup protocol-family r> open-socket
|
||||
dup close-socket-later
|
||||
dup rot make-sockaddr/size bind socket-error ;
|
||||
|
||||
USE: namespaces
|
||||
|
||||
! http://support.microsoft.com/kb/127144
|
||||
! NOTE: Possibly tweak this because of SYN flood attacks
|
||||
: listen-backlog ( -- n ) HEX: 7fffffff ; inline
|
||||
|
||||
: listen-on-socket ( socket -- )
|
||||
listen-backlog listen winsock-return-check ;
|
||||
|
||||
M: win32-socket dispose ( stream -- )
|
||||
win32-file-handle closesocket drop ;
|
||||
|
||||
M: windows addrinfo-error ( n -- )
|
||||
winsock-return-check ;
|
||||
|
||||
: tcp-socket ( addrspec -- socket )
|
||||
protocol-family SOCK_STREAM open-socket ;
|
||||
|
|
|
|||
|
|
@ -167,6 +167,8 @@ FUNCTION: int shutdown ( SOCKET s, int how ) ;
|
|||
FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
|
||||
FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
|
||||
|
||||
FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
|
||||
|
||||
TYPEDEF: uint SERVICETYPE
|
||||
TYPEDEF: OVERLAPPED WSAOVERLAPPED
|
||||
TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
|
||||
|
|
|
|||
Loading…
Reference in New Issue