steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Further cleanups

db4
U-SLAVA-DFB8FF805\Slava 2008-05-15 01:45:32 -05:00
parent 667345e883
commit 60818847da
10 changed files with 249 additions and 168 deletions

114
extra/io/windows/files/files.factor
View File

@ -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 ;

16
extra/io/windows/launcher/launcher.factor
View File

@ -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 [

2
extra/io/windows/mmap/mmap.factor
View File

@ -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 )

36
extra/io/windows/nt/backend/backend.factor
View File

@ -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 ;

37
extra/io/windows/nt/files/files.factor
View File

@ -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 ;

22
extra/io/windows/nt/launcher/launcher.factor
View File

@ -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

6
extra/io/windows/nt/monitors/monitors.factor
View File

@ -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 ;

13
extra/io/windows/nt/pipes/pipes.factor
View File

@ -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 ;

118
extra/io/windows/nt/sockets/sockets.factor
View File

@ -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 ;

53
extra/io/windows/sockets/sockets.factor Executable file
View File

@ -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 ;