Major overhaul of Windows I/O code: simpler, more readable, more efficient, more robust
U-SLAVA-DFB8FF805\Slava
parent
70c2f420ec
commit
29556e2a2b
|
|
@ -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,19 +1,17 @@
|
|||
! 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
|
||||
dup invalid-handle?
|
||||
<win32-file>
|
||||
|dispose
|
||||
dup add-completion
|
||||
CreateFile-flags f CreateFile opened-file
|
||||
] with-destructors ;
|
||||
|
||||
: open-pipe-r/w ( path -- win32-file )
|
||||
|
|
@ -213,7 +211,7 @@ M: winnt link-info ( path -- info )
|
|||
|
||||
: file-times ( path -- timestamp timestamp timestamp )
|
||||
[
|
||||
normalize-path open-existing &close-handle
|
||||
normalize-path open-existing &dispose handle>>
|
||||
"FILETIME" <c-object>
|
||||
"FILETIME" <c-object>
|
||||
"FILETIME" <c-object>
|
||||
|
|
@ -229,7 +227,7 @@ M: winnt link-info ( path -- info )
|
|||
#! timestamp order: creation access write
|
||||
[
|
||||
>r >r >r
|
||||
normalize-path open-existing &close-handle
|
||||
normalize-path open-existing &dispose handle>>
|
||||
r> r> r> (set-file-times)
|
||||
] with-destructors ;
|
||||
|
||||
|
|
@ -246,5 +244,5 @@ M: winnt touch-file ( path -- )
|
|||
[
|
||||
normalize-path
|
||||
maybe-create-file >r &dispose r>
|
||||
[ drop ] [ f now dup (set-file-times) ] if
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -1,86 +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 } flags "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 &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 ;
|
||||
|
||||
: 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 |close-handle
|
||||
dup
|
||||
r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep |close-handle
|
||||
] with-privileges ;
|
||||
|
||||
M: windows (mapped-file)
|
||||
[
|
||||
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
|
||||
-rot <win32-mapped-file>
|
||||
] with-destructors ;
|
||||
|
||||
M: windows close-mapped-file ( mapped-file -- )
|
||||
[
|
||||
[ handle>> [ &close-handle drop ] each ]
|
||||
[ address>> UnmapViewOfFile win32-error=0/f ]
|
||||
bi
|
||||
[ 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
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -64,7 +65,6 @@ M: winnt add-completion ( handle -- )
|
|||
|
||||
:: wait-for-overlapped ( ms -- overlapped ? )
|
||||
master-completion-port get-global
|
||||
r> INFINITE or ! timeout
|
||||
0 <int> ! bytes
|
||||
f <void*> ! key
|
||||
f <void*> ! overlapped
|
||||
|
|
@ -82,9 +82,9 @@ M: winnt add-completion ( handle -- )
|
|||
GetLastError dup expected-io-error? [ 2drop f ] [
|
||||
>r lookup-callback [ thread>> ] [ port>> ] bi r>
|
||||
dup eof?
|
||||
[ drop t >>eof drop ]
|
||||
[ (win32-error-string) >>error drop ] if
|
||||
thread>> resume t
|
||||
[ drop t >>eof ]
|
||||
[ (win32-error-string) >>error ] if drop
|
||||
resume t
|
||||
] if
|
||||
] [
|
||||
lookup-callback
|
||||
|
|
@ -102,6 +102,9 @@ M: winnt init-io ( -- )
|
|||
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 ;
|
||||
|
||||
|
|
@ -124,7 +127,7 @@ M: winnt (wait-to-write)
|
|||
over zero? [
|
||||
t >>eof 2drop
|
||||
] [
|
||||
[ buffer>> n>buffer ] [ update-file-ptr ] bi
|
||||
[ buffer>> n>buffer ] [ update-file-ptr ] 2bi
|
||||
] if ;
|
||||
|
||||
: ((wait-to-read)) ( port -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -55,7 +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 -- )
|
||||
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
|
||||
>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' )
|
||||
|
|
@ -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? <win32-file> &dispose ;
|
||||
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 ] }
|
||||
|
|
@ -78,21 +78,20 @@ IN: io.windows.nt.launcher
|
|||
} cond ;
|
||||
|
||||
: redirect-stdout ( process args -- handle )
|
||||
drop
|
||||
stdout>>
|
||||
GENERIC_WRITE
|
||||
CREATE_ALWAYS
|
||||
redirect
|
||||
STD_OUTPUT_HANDLE GetStdHandle ;
|
||||
STD_OUTPUT_HANDLE GetStdHandle or ;
|
||||
|
||||
: 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
|
||||
|
|
@ -100,11 +99,12 @@ IN: io.windows.nt.launcher
|
|||
] if ;
|
||||
|
||||
: redirect-stdin ( process args -- handle )
|
||||
drop
|
||||
stdin>>
|
||||
GENERIC_READ
|
||||
OPEN_EXISTING
|
||||
redirect
|
||||
STD_INPUT_HANDLE GetStdHandle ;
|
||||
STD_INPUT_HANDLE GetStdHandle or ;
|
||||
|
||||
M: winnt fill-redirection ( process args -- )
|
||||
[ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
|
||||
|
|
|
|||
|
|
@ -17,11 +17,7 @@ IN: io.windows.nt.monitors
|
|||
OPEN_EXISTING
|
||||
{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
|
||||
f
|
||||
CreateFile
|
||||
dup invalid-handle?
|
||||
<win32-file>
|
||||
|close-handle
|
||||
dup add-completion ;
|
||||
CreateFile opened-file ;
|
||||
|
||||
TUPLE: win32-monitor-port < input-port recursive ;
|
||||
|
||||
|
|
@ -93,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
|
||||
<win32-file> |dispose
|
||||
dup add-completion ;
|
||||
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
|
||||
<win32-file> |dispose
|
||||
dup add-completion ;
|
||||
CreateFile opened-file ;
|
||||
|
||||
: unique-pipe-name ( -- string )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
@ -11,9 +12,6 @@ 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
|
||||
|
|
@ -33,7 +31,10 @@ TUPLE: ConnectEx-args port
|
|||
s* name* namelen* lpSendBuffer* dwSendDataLength*
|
||||
lpdwBytesSent* lpOverlapped* ptr* ;
|
||||
|
||||
: <ConnectEx-args> ( sockaddr size -- )
|
||||
: wait-for-socket ( args -- n )
|
||||
[ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
|
||||
|
||||
: <ConnectEx-args> ( sockaddr size -- ConnectEx )
|
||||
ConnectEx-args new
|
||||
swap >>namelen*
|
||||
swap >>name*
|
||||
|
|
@ -61,18 +62,18 @@ TUPLE: AcceptEx-args port
|
|||
sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
|
||||
dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ;
|
||||
|
||||
: init-accept-buffer ( server-port AcceptEx -- )
|
||||
swap addr>> sockaddr-type heap-size 16 +
|
||||
: init-accept-buffer ( addr AcceptEx -- )
|
||||
swap sockaddr-type heap-size 16 +
|
||||
[ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi
|
||||
dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer*
|
||||
drop ;
|
||||
|
||||
: <AcceptEx-args> ( server-port -- AcceptEx )
|
||||
: <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
|
||||
dup port>> handle>> handle>> >>sListenSocket*
|
||||
dup port>> addr>> tcp-socket >>sAcceptSocket*
|
||||
0 >>dwReceiveDataLength*
|
||||
f >>lpdwBytesReceived*
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
|
|
@ -81,20 +82,17 @@ TUPLE: AcceptEx-args port
|
|||
AcceptEx-args >tuple*< AcceptEx drop
|
||||
winsock-error-string [ throw ] when* ;
|
||||
|
||||
: finish-accept ( AcceptEx -- client )
|
||||
sAcceptSocket*>> [ <win32-socket> |dispose ] [ add-completion ] bi ;
|
||||
|
||||
M: winnt (accept) ( server -- handle )
|
||||
M: object (accept) ( server addr -- handle )
|
||||
[
|
||||
[
|
||||
<AcceptEx-args>
|
||||
{
|
||||
[ call-AcceptEx ]
|
||||
[ wait-for-socket drop ]
|
||||
[ finish-accept ]
|
||||
[ sAcceptSocket*>> opened-socket ]
|
||||
[ port>> pending-error ]
|
||||
} cleave
|
||||
] with-timeout
|
||||
] curry with-timeout
|
||||
] with-destructors ;
|
||||
|
||||
TUPLE: WSARecvFrom-args port
|
||||
|
|
@ -107,7 +105,7 @@ TUPLE: WSARecvFrom-args port
|
|||
default-buffer-size get malloc &free over set-WSABUF-buf ;
|
||||
|
||||
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
|
||||
WSARecvFrom new
|
||||
WSARecvFrom-args new
|
||||
swap >>port
|
||||
dup port>> handle>> handle>> >>s*
|
||||
dup port>> addr>> sockaddr-type heap-size
|
||||
|
|
@ -125,7 +123,7 @@ TUPLE: WSARecvFrom-args port
|
|||
: 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 )
|
||||
[
|
||||
<WSARecvFrom-args>
|
||||
{
|
||||
|
|
@ -163,7 +161,7 @@ TUPLE: WSASendTo-args port
|
|||
: call-WSASendTo ( WSASendTo -- )
|
||||
WSASendTo-args >tuple*< WSASendTo socket-error* ;
|
||||
|
||||
M: winnt send ( packet addrspec datagram -- )
|
||||
M: winnt (send) ( packet addrspec datagram -- )
|
||||
[
|
||||
<WSASendTo-args>
|
||||
[ call-WSASendTo ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel accessors io.sockets io.windows
|
||||
windows.winsock system ;
|
||||
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 )
|
||||
|
|
@ -17,24 +17,29 @@ M: win32-socket dispose ( stream -- )
|
|||
[ empty-sockaddr/size ] [ protocol-family ] bi
|
||||
pick set-sockaddr-in-family ;
|
||||
|
||||
: open-socket ( addrspec type -- win3-socket )
|
||||
: 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
|
||||
<win32-socket> |dispose
|
||||
dup add-completion ;
|
||||
opened-socket ;
|
||||
|
||||
M: object get-local-address ( socket addrspec -- sockaddr )
|
||||
>r handle>> r> empty-sockaddr/size
|
||||
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 )
|
||||
[ open-socket ] [ drop ] 2bi
|
||||
[ unspecific-sockaddr/size bind socket-error ] [ drop ] 2bi ;
|
||||
[ 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-error ] [ drop ] 2bi ;
|
||||
[ make-sockaddr/size bind-socket ] [ drop ] 2bi ;
|
||||
|
||||
! http://support.microsoft.com/kb/127144
|
||||
! NOTE: Possibly tweak this because of SYN flood attacks
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ TUPLE: win32-handle handle disposed ;
|
|||
M: win32-handle dispose* ( handle -- )
|
||||
handle>> CloseHandle drop ;
|
||||
|
||||
TUPLE: win32-file handle ptr disposed ;
|
||||
TUPLE: win32-file < win32-handle ptr ;
|
||||
|
||||
: <win32-file> ( handle -- win32-file )
|
||||
win32-file new-win32-handle ;
|
||||
|
|
@ -31,6 +31,11 @@ HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
|
|||
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
|
||||
HOOK: add-completion io-backend ( port -- )
|
||||
|
||||
: opened-file ( handle -- win32-file )
|
||||
dup invalid-handle?
|
||||
<win32-file> |dispose
|
||||
dup add-completion ;
|
||||
|
||||
: share-mode ( -- fixnum )
|
||||
{
|
||||
FILE_SHARE_READ
|
||||
|
|
|
|||
|
|
@ -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