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

Merge branch 'master' into experimental

db4
Alex Chapman 2008-05-16 08:41:26 +10:00
parent 12be2d1b9c d7b296211e
commit 30bb157b31
26 changed files with 570 additions and 628 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
core/libc/libc-tests.factor Executable file
View File

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

6
core/libc/libc.factor
View File

@ -81,14 +81,14 @@ PRIVATE>
<PRIVATE <PRIVATE
! Memory allocations ! Memory allocations
TUPLE: memory-destructor alien ; TUPLE: memory-destructor alien disposed ;
M: memory-destructor dispose* alien>> free ; M: memory-destructor dispose* alien>> free ;
PRIVATE> PRIVATE>
: &free ( alien -- alien ) : &free ( alien -- alien )
dup memory-destructor boa &dispose drop ; inline dup f memory-destructor boa &dispose drop ; inline
: |free ( alien -- alien ) : |free ( alien -- alien )
dup memory-destructor boa |dispose drop ; inline dup f memory-destructor boa |dispose drop ; inline

5
extra/io/mmap/mmap-docs.factor
View File

@ -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." } { $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." } ; { $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 HELP: close-mapped-file
{ $values { "mmap" 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." } { $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }

17
extra/io/mmap/mmap-tests.factor
View File

@ -2,11 +2,14 @@ USING: io io.mmap io.files kernel tools.test continuations
sequences io.encodings.ascii accessors ; sequences io.encodings.ascii accessors ;
IN: io.mmap.tests IN: io.mmap.tests
[ "resource:mmap-test-file.txt" delete-file ] ignore-errors [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ ] [ "12345" "resource:mmap-test-file.txt" ascii set-file-contents ] unit-test [ ] [ "12345" "mmap-test-file.txt" temp-file 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 [ ] [ "mmap-test-file.txt" temp-file 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 [ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "resource:mmap-test-file.txt" ascii file-contents ] unit-test [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "resource:mmap-test-file.txt" delete-file ] ignore-errors [ "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

6
extra/io/sockets/sockets.factor
View File

@ -27,10 +27,10 @@ GENERIC: inet-ntop ( data addrspec -- str )
GENERIC: inet-pton ( str addrspec -- data ) GENERIC: inet-pton ( str addrspec -- data )
: make-sockaddr/size ( addrspec -- sockaddr size ) : 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 ) : empty-sockaddr/size ( addrspec -- sockaddr size )
sockaddr-type [ <c-object> ] [ heap-size <int> ] bi ; sockaddr-type [ <c-object> ] [ heap-size ] bi ;
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec ) GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )

5
extra/io/unix/mmap/mmap.factor
View File

@ -6,7 +6,7 @@ IN: io.unix.mmap
: open-r/w ( path -- fd ) O_RDWR file-mode open-file ; : 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 f length prot flags
path open-r/w |dispose path open-r/w |dispose
@ -14,10 +14,9 @@ IN: io.unix.mmap
] with-destructors ; ] with-destructors ;
M: unix (mapped-file) M: unix (mapped-file)
swap >r
{ PROT_READ PROT_WRITE } flags { PROT_READ PROT_WRITE } flags
{ MAP_FILE MAP_SHARED } flags { MAP_FILE MAP_SHARED } flags
r> mmap-open ; mmap-open ;
M: unix close-mapped-file ( mmap -- ) M: unix close-mapped-file ( mmap -- )
[ [ address>> ] [ length>> ] bi munmap io-error ] [ [ address>> ] [ length>> ] bi munmap io-error ]

45
extra/io/unix/sockets/secure/secure.factor
View File

@ -9,10 +9,6 @@ io.encodings.ascii io.buffers io.sockets io.sockets.secure
unix system ; unix system ;
IN: io.unix.sockets.secure IN: io.unix.sockets.secure
! todo: SSL_pending, rehandshake
! check-certificate at some point
! test on windows
M: ssl-handle handle-fd file>> handle-fd ; M: ssl-handle handle-fd file>> handle-fd ;
: syscall-error ( r -- * ) : syscall-error ( r -- * )
@ -78,6 +74,8 @@ M: ssl ((client)) ( addrspec -- handle )
M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ; M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
M: ssl (get-local-address) addrspec>> (get-local-address) ;
: check-connect-response ( port r -- event ) : check-connect-response ( port r -- event )
check-response check-response
{ {
@ -88,15 +86,15 @@ M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
{ SSL_ERROR_SSL [ (ssl-error) ] } { SSL_ERROR_SSL [ (ssl-error) ] }
} case ; } case ;
: do-ssl-connect ( port ssl-handle -- ) : do-ssl-connect ( port -- )
2dup SSL_connect check-connect-response dup dup dup handle>> handle>> SSL_connect
[ >r over r> wait-for-port do-ssl-connect ] [ 3drop ] if ; check-connect-response dup
[ dupd wait-for-port do-ssl-connect ] [ 2drop ] if ;
M: ssl establish-connection ( client-out remote -- ) M: ssl establish-connection ( client-out remote -- )
addrspec>> [ addrspec>> establish-connection ]
[ establish-connection ] [ drop do-ssl-connect ]
[ drop dup handle>> do-ssl-connect ] [ drop handle>> t >>connected drop ]
[ drop t >>connected drop ]
2tri ; 2tri ;
M: ssl (server) addrspec>> (server) ; M: ssl (server) addrspec>> (server) ;
@ -122,16 +120,29 @@ M: ssl (accept)
] with-destructors ; ] with-destructors ;
: check-shutdown-response ( handle r -- event ) : check-shutdown-response ( handle r -- event )
>r handle>> r> SSL_get_error #! SSL_shutdown always returns 0 due to openssl bugs?
{ {
{ SSL_ERROR_WANT_READ [ +input+ ] } { 1 [ drop f ] }
{ SSL_ERROR_WANT_WRITE [ +output+ ] } { 0 [
{ SSL_ERROR_SYSCALL [ -1 syscall-error ] } dup SSL_want {
{ SSL_ERROR_SSL [ (ssl-error) ] } { SSL_NOTHING [ dup SSL_shutdown check-shutdown-response ] }
{ SSL_READING [ drop +input+ ] }
{ SSL_WRITING [ drop +output+ ] }
} case
] }
{ -1 [
-1 SSL_get_error
{
{ SSL_ERROR_WANT_READ [ +input+ ] }
{ SSL_ERROR_WANT_WRITE [ +output+ ] }
{ SSL_ERROR_SYSCALL [ -1 syscall-error ] }
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case
] }
} case ; } case ;
M: unix ssl-shutdown M: unix ssl-shutdown
dup connected>> [ dup connected>> [
dup dup handle>> SSL_shutdown check-shutdown-response dup handle>> dup SSL_shutdown check-shutdown-response
dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if
] [ drop ] if ; ] [ drop ] if ;

6
extra/io/unix/sockets/sockets.factor Normal file → Executable file
View File

@ -23,7 +23,7 @@ M: unix addrinfo-error ( n -- )
! Client sockets - TCP and Unix domain ! Client sockets - TCP and Unix domain
M: object (get-local-address) ( handle remote -- sockaddr ) 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 ; [ getsockname io-error ] 2keep drop ;
: init-client-socket ( fd -- ) : init-client-socket ( fd -- )
@ -67,7 +67,7 @@ M: object (server) ( addrspec -- handle )
] with-destructors ; ] with-destructors ;
: do-accept ( server addrspec -- fd ) : 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 ) M: object (accept) ( server addrspec -- fd )
2dup do-accept 2dup do-accept
@ -100,7 +100,7 @@ packet-size <byte-array> receive-buffer set-global
packet-size ! nbytes packet-size ! nbytes
0 ! flags 0 ! flags
sockaddr ! from sockaddr ! from
len ! fromlen len <int> ! fromlen
recvfrom dup 0 >= [ recvfrom dup 0 >= [
receive-buffer get-global swap head sockaddr receive-buffer get-global swap head sockaddr
] [ ] [

4
extra/io/windows/ce/privileges/privileges.factor Executable file
View File

@ -0,0 +1,4 @@
IN: io.windows.ce.privileges
USING: io.windows.privileges system ;
M: wince set-privilege 2drop ;

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

@ -1,11 +1,121 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces words symbols system 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 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+ SYMBOLS: +read-only+ +hidden+ +system+
+archive+ +device+ +normal+ +temporary+ +archive+ +device+ +normal+ +temporary+
+sparse-file+ +reparse-point+ +compressed+ +offline+ +sparse-file+ +reparse-point+ +compressed+ +offline+
@ -101,7 +211,7 @@ M: winnt link-info ( path -- info )
: file-times ( path -- timestamp timestamp timestamp ) : 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> "FILETIME" <c-object>
"FILETIME" <c-object> "FILETIME" <c-object>
@ -117,7 +227,7 @@ M: winnt link-info ( path -- info )
#! timestamp order: creation access write #! timestamp order: creation access write
[ [
>r >r >r >r >r >r
normalize-path open-existing dup close-always normalize-path open-existing &dispose handle>>
r> r> r> (set-file-times) r> r> r> (set-file-times)
] with-destructors ; ] with-destructors ;
@ -133,6 +243,6 @@ M: winnt link-info ( path -- info )
M: winnt touch-file ( path -- ) M: winnt touch-file ( path -- )
[ [
normalize-path normalize-path
maybe-create-file over close-always 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 ; ] with-destructors ;

6
extra/io/windows/files/unique/unique.factor Normal file → Executable file
View File

@ -1,10 +1,10 @@
USING: kernel system io.files.unique.backend 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 IN: io.windows.files.unique
M: windows (make-unique-file) ( path -- ) M: windows (make-unique-file) ( path -- )
GENERIC_WRITE CREATE_NEW 0 open-file GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
CloseHandle win32-error=0/f ;
M: windows temporary-path ( -- path ) M: windows temporary-path ( -- path )
"TEMP" os-env ; "TEMP" os-env ;

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

@ -6,7 +6,7 @@ windows.types math windows.kernel32
namespaces io.launcher kernel sequences windows.errors namespaces io.launcher kernel sequences windows.errors
splitting system threads init strings combinators splitting system threads init strings combinators
io.backend accessors concurrency.flags io.files assocs 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 IN: io.windows.launcher
TUPLE: CreateProcess-args TUPLE: CreateProcess-args
@ -19,8 +19,7 @@ TUPLE: CreateProcess-args
lpEnvironment lpEnvironment
lpCurrentDirectory lpCurrentDirectory
lpStartupInfo lpStartupInfo
lpProcessInformation lpProcessInformation ;
stdout-pipe stdin-pipe ;
: default-CreateProcess-args ( -- obj ) : default-CreateProcess-args ( -- obj )
CreateProcess-args new CreateProcess-args new
@ -31,18 +30,7 @@ TUPLE: CreateProcess-args
0 >>dwCreateFlags ; 0 >>dwCreateFlags ;
: call-CreateProcess ( CreateProcess-args -- ) : call-CreateProcess ( CreateProcess-args -- )
{ CreateProcess-args >tuple< CreateProcess win32-error=0/f ;
lpApplicationName>>
lpCommandLine>>
lpProcessAttributes>>
lpThreadAttributes>>
bInheritHandles>>
dwCreateFlags>>
lpEnvironment>>
lpCurrentDirectory>>
lpStartupInfo>>
lpProcessInformation>>
} get-slots CreateProcess win32-error=0/f ;
: count-trailing-backslashes ( str n -- str n ) : count-trailing-backslashes ( str n -- str n )
>r "\\" ?tail [ >r "\\" ?tail [

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

@ -1,88 +1,44 @@
USING: alien alien.c-types alien.syntax arrays continuations USING: alien alien.c-types arrays destructors generic io.mmap
destructors generic io.mmap io.ports io.windows io.ports io.windows io.windows.files io.windows.privileges
kernel libc math namespaces quotations sequences windows kernel libc math math.bitfields namespaces quotations sequences
windows.advapi32 windows.kernel32 io.backend system ; windows windows.advapi32 windows.kernel32 io.backend system
accessors locals ;
IN: io.windows.mmap IN: io.windows.mmap
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES : create-file-mapping
CreateFileMapping [ win32-error=0/f ] keep <win32-handle> ;
! Security tokens : map-view-of-file
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ MapViewOfFile [ win32-error=0/f ] keep ;
: (open-process-token) ( handle -- handle ) :: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY bitor "PHANDLE" <c-object> [let | lo [ length HEX: ffffffff bitand ]
[ OpenProcessToken win32-error=0/f ] keep *void* ; 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 ) TUPLE: win32-mapped-file file mapping ;
#! remember to handle-close this
GetCurrentProcess (open-process-token) ;
: with-process-token ( quot -- ) M: win32-mapped-file dispose
#! quot: ( token-handle -- token-handle ) [ file>> dispose ] [ mapping>> dispose ] bi ;
>r open-process-token r>
[ keep ] curry
[ CloseHandle drop ] [ ] cleanup ; inline
: lookup-privilege ( string -- luid ) C: <win32-mapped-file> win32-mapped-file
>r f r> "LUID" <c-object>
[ LookupPrivilegeValue win32-error=0/f ] keep ;
: make-token-privileges ( name ? -- obj ) M: windows (mapped-file)
"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>
[ [
TOKEN_PRIVILEGES-Privileges { GENERIC_WRITE GENERIC_READ } flags
>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
OPEN_ALWAYS OPEN_ALWAYS
PAGE_READWRITE SEC_COMMIT bitor { PAGE_READWRITE SEC_COMMIT } flags
FILE_MAP_ALL_ACCESS mmap-open FILE_MAP_ALL_ACCESS mmap-open
-rot 2array -rot <win32-mapped-file>
f \ mapped-file boa
] with-destructors ; ] with-destructors ;
M: windows close-mapped-file ( mapped-file -- ) M: windows close-mapped-file ( mapped-file -- )
[ [
dup mapped-file-handle [ close-always ] each [ handle>> &dispose drop ]
mapped-file-address UnmapViewOfFile win32-error=0/f [ address>> UnmapViewOfFile win32-error=0/f ] bi
] with-destructors ; ] with-destructors ;

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

@ -1,9 +1,10 @@
USING: alien alien.c-types arrays assocs combinators USING: alien alien.c-types arrays assocs combinators
continuations destructors io io.backend io.ports continuations destructors io io.backend io.ports io.timeouts
io.windows libc kernel math namespaces sequences io.windows io.windows.files libc kernel math namespaces
threads classes.tuple.lib windows windows.errors sequences threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files qualified ascii windows.kernel32 strings splitting io.files
combinators.lib system accessors ; io.buffers qualified ascii combinators.lib system
accessors locals ;
QUALIFIED: windows.winsock QUALIFIED: windows.winsock
IN: io.windows.nt.backend IN: io.windows.nt.backend
@ -14,11 +15,11 @@ TUPLE: io-callback port thread ;
C: <io-callback> io-callback C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext ) : (make-overlapped) ( -- overlapped-ext )
"OVERLAPPED" malloc-object dup free-always ; "OVERLAPPED" malloc-object &free ;
: make-overlapped ( port -- overlapped-ext ) : make-overlapped ( port -- overlapped-ext )
>r (make-overlapped) r> port-handle win32-file-ptr >r (make-overlapped)
[ over set-OVERLAPPED-offset ] when* ; r> handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
: <completion-port> ( handle existing -- handle ) : <completion-port> ( handle existing -- handle )
f 1 CreateIoCompletionPort dup win32-error=0/f ; f 1 CreateIoCompletionPort dup win32-error=0/f ;
@ -28,8 +29,8 @@ SYMBOL: master-completion-port
: <master-completion-port> ( -- handle ) : <master-completion-port> ( -- handle )
INVALID_HANDLE_VALUE f <completion-port> ; INVALID_HANDLE_VALUE f <completion-port> ;
M: winnt add-completion ( handle -- ) M: winnt add-completion ( win32-handle -- )
master-completion-port get-global <completion-port> drop ; handle>> master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? ) : eof? ( error -- ? )
dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ; dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ;
@ -56,13 +57,21 @@ M: winnt add-completion ( handle -- )
io-hash get-global set-at io-hash get-global set-at
] "I/O" suspend 3drop ; ] "I/O" suspend 3drop ;
: wait-for-overlapped ( ms -- overlapped ? ) : twiddle-thumbs ( overlapped port -- bytes-transferred )
>r master-completion-port get-global [ save-callback ]
r> INFINITE or ! timeout [ get-overlapped-result ]
[ nip pending-error ]
2tri ;
:: wait-for-overlapped ( ms -- overlapped ? )
master-completion-port get-global
0 <int> ! bytes 0 <int> ! bytes
f <void*> ! key f <void*> ! key
f <void*> ! overlapped f <void*> ! overlapped
[ roll GetQueuedCompletionStatus ] keep *void* swap zero? ; [
ms INFINITE or ! timeout
GetQueuedCompletionStatus
] keep *void* swap zero? ;
: lookup-callback ( overlapped -- callback ) : lookup-callback ( overlapped -- callback )
io-hash get-global delete-at* drop io-hash get-global delete-at* drop
@ -70,32 +79,64 @@ M: winnt add-completion ( handle -- )
: handle-overlapped ( timeout -- ? ) : handle-overlapped ( timeout -- ? )
wait-for-overlapped [ wait-for-overlapped [
GetLastError dup expected-io-error? [ GetLastError dup expected-io-error? [ 2drop f ] [
2drop t >r lookup-callback [ thread>> ] [ port>> ] bi r>
] [ dup eof?
dup eof? [ [ drop t >>eof ]
drop lookup-callback [ (win32-error-string) >>error ] if drop
dup port>> t >>eof drop resume t
] [
(win32-error-string) swap lookup-callback
[ port>> set-port-error ] keep
] if thread>> resume f
] if ] if
] [ ] [
lookup-callback lookup-callback
io-callback-thread resume f thread>> resume t
] if ; ] if ;
: drain-overlapped ( timeout -- )
handle-overlapped [ 0 drain-overlapped ] unless ;
M: winnt cancel-io M: winnt cancel-io
handle>> handle>> CancelIo drop ; handle>> handle>> CancelIo drop ;
M: winnt io-multiplex ( ms -- ) M: winnt io-multiplex ( ms -- )
drain-overlapped ; handle-overlapped [ 0 io-multiplex ] when ;
M: winnt init-io ( -- ) M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global <master-completion-port> master-completion-port set-global
H{ } clone io-hash set-global H{ } clone io-hash set-global
windows.winsock:init-winsock ; 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 ;

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

@ -1,6 +1,7 @@
USING: continuations destructors io.buffers io.files io.backend USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.ports io.windows io.windows.nt.backend io.timeouts io.ports io.windows io.windows.files
kernel libc math threads windows windows.kernel32 system io.windows.nt.backend windows windows.kernel32
kernel libc math threads system
alien.c-types alien.arrays alien.strings sequences combinators alien.c-types alien.arrays alien.strings sequences combinators
combinators.lib sequences.lib ascii splitting alien strings combinators.lib sequences.lib ascii splitting alien strings
assocs namespaces io.files.private accessors ; assocs namespaces io.files.private accessors ;
@ -29,6 +30,7 @@ M: winnt root-directory? ( path -- ? )
} cond nip ; } cond nip ;
ERROR: not-absolute-path ; ERROR: not-absolute-path ;
: root-directory ( string -- string' ) : root-directory ( string -- string' )
{ {
[ dup length 2 >= ] [ dup length 2 >= ]
@ -54,57 +56,4 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
M: winnt open-append M: winnt open-append
[ dup file-info size>> ] [ drop 0 ] recover [ dup file-info size>> ] [ drop 0 ] recover
>r (open-append) r> ; >r (open-append) r> >>ptr ;
: 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 ;

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

@ -4,8 +4,9 @@ USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.ports io.pipes windows.types io.windows libc io.ports io.pipes windows.types
math windows.kernel32 windows namespaces io.launcher kernel math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings sequences windows.errors assocs splitting system strings
io.windows.launcher io.windows.nt.pipes io.backend io.files io.windows.launcher io.windows.files
io.files.private combinators shuffle accessors locals ; io.backend io.files io.files.private combinators shuffle
accessors locals ;
IN: io.windows.nt.launcher IN: io.windows.nt.launcher
: duplicate-handle ( handle -- handle' ) : duplicate-handle ( handle -- handle' )
@ -21,10 +22,10 @@ IN: io.windows.nt.launcher
! /dev/null simulation ! /dev/null simulation
: null-input ( -- pipe ) : null-input ( -- pipe )
(pipe) [ in>> handle>> ] [ out>> close-handle ] bi ; (pipe) [ in>> handle>> ] [ out>> dispose ] bi ;
: null-output ( -- pipe ) : null-output ( -- pipe )
(pipe) [ in>> close-handle ] [ out>> handle>> ] bi ; (pipe) [ in>> dispose ] [ out>> handle>> ] bi ;
: null-pipe ( mode -- pipe ) : null-pipe ( mode -- pipe )
{ {
@ -35,13 +36,13 @@ IN: io.windows.nt.launcher
! The below code is based on the example given in ! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: redirect-default ( default obj access-mode create-mode -- handle ) : redirect-default ( obj access-mode create-mode -- handle )
3drop ; 3drop f ;
: redirect-closed ( default obj access-mode create-mode -- handle ) : redirect-closed ( obj access-mode create-mode -- handle )
drop 2nip null-pipe ; drop nip null-pipe ;
:: redirect-file ( default path access-mode create-mode -- handle ) :: redirect-file ( path access-mode create-mode -- handle )
path normalize-path path normalize-path
access-mode access-mode
share-mode share-mode
@ -49,9 +50,9 @@ IN: io.windows.nt.launcher
create-mode create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file 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> >r >r path>> r> r>
drop OPEN_ALWAYS drop OPEN_ALWAYS
redirect-file redirect-file
@ -60,14 +61,13 @@ IN: io.windows.nt.launcher
: set-inherit ( handle ? -- ) : set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
: redirect-handle ( default handle access-mode create-mode -- handle ) : redirect-handle ( handle access-mode create-mode -- handle )
2drop nip 2drop handle>> duplicate-handle dup t set-inherit ;
handle>> duplicate-handle dup t set-inherit ;
: redirect-stream ( default stream access-mode create-mode -- handle ) : redirect-stream ( stream access-mode create-mode -- handle )
>r >r underlying-handle r> r> redirect-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 not ] [ redirect-default ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] } { [ pick +closed+ eq? ] [ redirect-closed ] }
@ -77,12 +77,9 @@ IN: io.windows.nt.launcher
[ redirect-stream ] [ redirect-stream ]
} cond ; } cond ;
: default-stdout ( args -- handle )
stdout-pipe>> dup [ out>> ] when ;
: redirect-stdout ( process args -- handle ) : redirect-stdout ( process args -- handle )
default-stdout drop
swap stdout>> stdout>>
GENERIC_WRITE GENERIC_WRITE
CREATE_ALWAYS CREATE_ALWAYS
redirect redirect
@ -90,25 +87,20 @@ IN: io.windows.nt.launcher
: redirect-stderr ( process args -- handle ) : redirect-stderr ( process args -- handle )
over stderr>> +stdout+ eq? [ over stderr>> +stdout+ eq? [
lpStartupInfo>>
STARTUPINFO-hStdOutput
nip nip
lpStartupInfo>> STARTUPINFO-hStdOutput
] [ ] [
drop drop
f stderr>>
swap stderr>>
GENERIC_WRITE GENERIC_WRITE
CREATE_ALWAYS CREATE_ALWAYS
redirect redirect
STD_ERROR_HANDLE GetStdHandle or STD_ERROR_HANDLE GetStdHandle or
] if ; ] if ;
: default-stdin ( args -- handle )
stdin-pipe>> dup [ in>> ] when ;
: redirect-stdin ( process args -- handle ) : redirect-stdin ( process args -- handle )
default-stdin drop
swap stdin>> stdin>>
GENERIC_READ GENERIC_READ
OPEN_EXISTING OPEN_EXISTING
redirect redirect

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

@ -17,11 +17,7 @@ IN: io.windows.nt.monitors
OPEN_EXISTING OPEN_EXISTING
{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
f f
CreateFile CreateFile opened-file ;
dup invalid-handle?
dup close-later
dup add-completion
f <win32-file> ;
TUPLE: win32-monitor-port < input-port recursive ; TUPLE: win32-monitor-port < input-port recursive ;
@ -41,11 +37,7 @@ TUPLE: win32-monitor < monitor port ;
: read-changes ( port -- bytes ) : read-changes ( port -- bytes )
[ [
dup begin-reading-changes [ begin-reading-changes ] [ twiddle-thumbs ] bi
swap [ save-callback ] 2keep
check-closed ! we may have closed it...
dup eof>> [ "EOF??" throw ] when
get-overlapped-result
] with-destructors ; ] with-destructors ;
: parse-action ( action -- changed ) : parse-action ( action -- changed )
@ -87,7 +79,7 @@ TUPLE: win32-monitor < monitor port ;
] each ; ] each ;
: fill-queue ( monitor -- ) : fill-queue ( monitor -- )
dup port>> check-closed dup port>> dup check-disposed
[ buffer>> ptr>> ] [ read-changes zero? ] bi [ buffer>> ptr>> ] [ read-changes zero? ] bi
[ 2dup parse-notify-records ] unless [ 2dup parse-notify-records ] unless
2drop ; 2drop ;
@ -97,7 +89,7 @@ TUPLE: win32-monitor < monitor port ;
: fill-queue-thread ( monitor -- ) : fill-queue-thread ( monitor -- )
[ dup fill-queue (fill-queue-thread) ] [ 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 ) M:: winnt (monitor) ( path recursive? mailbox -- monitor )
[ [

1
extra/io/windows/nt/nt.factor
View File

@ -7,6 +7,7 @@ USE: io.windows.nt.backend
USE: io.windows.nt.files USE: io.windows.nt.files
USE: io.windows.nt.launcher USE: io.windows.nt.launcher
USE: io.windows.nt.monitors USE: io.windows.nt.monitors
USE: io.windows.nt.privileges
USE: io.windows.nt.sockets USE: io.windows.nt.sockets
USE: io.windows.mmap USE: io.windows.mmap
USE: io.windows.files USE: io.windows.files

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

@ -17,10 +17,7 @@ IN: io.windows.nt.pipes
4096 4096
0 0
security-attributes-inherit security-attributes-inherit
CreateNamedPipe CreateNamedPipe opened-file ;
dup win32-error=0/f
dup add-completion
f <win32-file> ;
: open-other-end ( name -- handle ) : open-other-end ( name -- handle )
GENERIC_WRITE GENERIC_WRITE
@ -29,10 +26,7 @@ IN: io.windows.nt.pipes
OPEN_EXISTING OPEN_EXISTING
FILE_FLAG_OVERLAPPED FILE_FLAG_OVERLAPPED
f f
CreateFile CreateFile opened-file ;
dup win32-error=0/f
dup add-completion
f <win32-file> ;
: unique-pipe-name ( -- string ) : unique-pipe-name ( -- string )
[ [
@ -47,7 +41,6 @@ IN: io.windows.nt.pipes
M: winnt (pipe) ( -- pipe ) M: winnt (pipe) ( -- pipe )
[ [
unique-pipe-name unique-pipe-name
[ create-named-pipe dup close-later ] [ create-named-pipe ] [ open-other-end ] bi
[ open-other-end dup close-later ] pipe boa
bi pipe boa
] with-destructors ; ] with-destructors ;

53
extra/io/windows/nt/privileges/privileges.factor Executable file
View File

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

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

@ -1,8 +1,9 @@
USING: alien alien.accessors alien.c-types byte-arrays USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.ports io.timeouts io.sockets continuations destructors io.ports io.timeouts io.sockets
io.sockets io namespaces io.streams.duplex io.windows io.sockets io namespaces io.streams.duplex io.windows
io.windows.sockets
io.windows.nt.backend windows.winsock kernel libc math sequences 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 IN: io.windows.nt.sockets
: malloc-int ( object -- object ) : malloc-int ( object -- object )
@ -30,121 +31,68 @@ TUPLE: ConnectEx-args port
s* name* namelen* lpSendBuffer* dwSendDataLength* s* name* namelen* lpSendBuffer* dwSendDataLength*
lpdwBytesSent* lpOverlapped* ptr* ; lpdwBytesSent* lpOverlapped* ptr* ;
: init-connect ( sockaddr size ConnectEx -- ) : wait-for-socket ( args -- n )
[ set-ConnectEx-args-namelen* ] keep [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
[ 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* ;
: (ConnectEx) ( ConnectEx -- ) : <ConnectEx-args> ( sockaddr size -- ConnectEx )
\ ConnectEx-args >tuple*< ConnectEx-args new
swap >>namelen*
swap >>name*
f >>lpSendBuffer*
0 >>dwSendDataLength*
f >>lpdwBytesSent*
(make-overlapped) >>lpOverlapped* ;
: call-ConnectEx ( ConnectEx -- )
ConnectEx-args >tuple*<
"int" "int"
{ "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" } { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
"stdcall" alien-indirect drop "stdcall" alien-indirect drop
winsock-error-string [ throw ] when* ; winsock-error-string [ throw ] when* ;
: connect-continuation ( overlapped port -- ) M: object establish-connection ( client-out remote -- )
2dup save-callback make-sockaddr/size <ConnectEx-args>
get-overlapped-result drop ; swap >>port
dup port>> handle>> handle>> >>s*
M: win32-socket wait-to-connect ( client-out handle -- ) dup s*>> get-ConnectEx-ptr >>ptr*
[ overlapped>> swap connect-continuation ] dup call-ConnectEx
[ drop pending-error ] wait-for-socket drop ;
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 ;
TUPLE: AcceptEx-args port TUPLE: AcceptEx-args port
sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength* sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ; dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ;
: init-accept-buffer ( server-port AcceptEx -- ) : init-accept-buffer ( addr AcceptEx -- )
>r server-port-addr sockaddr-type heap-size 16 + swap sockaddr-type heap-size 16 +
dup dup 2 * malloc dup free-always r> [ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi
[ set-AcceptEx-args-lpOutputBuffer* ] keep dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer*
[ set-AcceptEx-args-dwLocalAddressLength* ] keep drop ;
set-AcceptEx-args-dwRemoteAddressLength* ;
: init-accept ( server-port AcceptEx -- ) : <AcceptEx-args> ( server addr -- AcceptEx )
[ init-accept-buffer ] 2keep AcceptEx-args new
[ set-AcceptEx-args-port ] 2keep 2dup init-accept-buffer
>r port-handle win32-file-handle r> [ set-AcceptEx-args-sListenSocket* ] keep swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket*
dup AcceptEx-args-port server-port-addr tcp-socket over handle>> handle>> >>sListenSocket*
over set-AcceptEx-args-sAcceptSocket* swap >>port
0 over set-AcceptEx-args-dwReceiveDataLength* 0 >>dwReceiveDataLength*
f over set-AcceptEx-args-lpdwBytesReceived* f >>lpdwBytesReceived*
(make-overlapped) swap set-AcceptEx-args-lpOverlapped* ; (make-overlapped) >>lpOverlapped* ;
: ((accept)) ( AcceptEx -- ) : call-AcceptEx ( AcceptEx -- )
\ AcceptEx-args >tuple*< AcceptEx-args >tuple*< AcceptEx drop
AcceptEx drop
winsock-error-string [ throw ] when* ; winsock-error-string [ throw ] when* ;
: make-accept-continuation ( AcceptEx -- ) M: object (accept) ( server addr -- handle )
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 )
[ [
[ [
\ AcceptEx-args new <AcceptEx-args>
[ init-accept ] keep {
[ ((accept)) ] keep [ call-AcceptEx ]
[ accept-continuation ] keep [ wait-for-socket drop ]
AcceptEx-args-port pending-error [ sAcceptSocket*>> opened-socket ]
] with-timeout [ port>> pending-error ]
] with-destructors ; } cleave
] curry with-timeout
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>
] with-destructors ; ] with-destructors ;
TUPLE: WSARecvFrom-args port TUPLE: WSARecvFrom-args port
@ -152,53 +100,38 @@ TUPLE: WSARecvFrom-args port
lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ; lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ;
: make-receive-buffer ( -- WSABUF ) : 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 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 -- ) : <WSARecvFrom-args> ( datagram -- WSARecvFrom )
[ set-WSARecvFrom-args-port ] 2keep WSARecvFrom-args new
[ swap >>port
>r handle>> handle>> r> dup port>> handle>> handle>> >>s*
set-WSARecvFrom-args-s* dup port>> addr>> sockaddr-type heap-size
] 2keep [ [ malloc &free >>lpFrom* ]
>r datagram-port-addr sockaddr-type heap-size r> [ malloc-int &free >>lpFromLen* ] bi
2dup >r malloc dup free-always r> set-WSARecvFrom-args-lpFrom* make-receive-buffer >>lpBuffers*
>r malloc-int dup free-always r> set-WSARecvFrom-args-lpFromLen* 1 >>dwBufferCount*
] keep 0 malloc-int &free >>lpFlags*
make-receive-buffer over set-WSARecvFrom-args-lpBuffers* 0 malloc-int &free >>lpNumberOfBytesRecvd*
1 over set-WSARecvFrom-args-dwBufferCount* (make-overlapped) >>lpOverlapped* ;
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 ;
: call-WSARecvFrom ( WSARecvFrom -- ) : call-WSARecvFrom ( WSARecvFrom -- )
\ WSARecvFrom-args >tuple*< WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
WSARecvFrom
socket-error* ;
: parse-WSARecvFrom ( n WSARecvFrom -- packet addrspec ) : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ;
WSARecvFrom-args-lpBuffers* WSABUF-buf
swap memory>byte-array
] keep
[ WSARecvFrom-args-lpFrom* ] keep
WSARecvFrom-args-port datagram-port-addr parse-sockaddr ;
M: winnt receive ( datagram -- packet addrspec ) M: winnt (receive) ( datagram -- packet addrspec )
[ [
check-datagram-port <WSARecvFrom-args>
\ WSARecvFrom-args new {
[ init-WSARecvFrom ] keep [ call-WSARecvFrom ]
[ call-WSARecvFrom ] keep [ wait-for-socket ]
[ WSARecvFrom-continuation ] keep [ port>> pending-error ]
[ WSARecvFrom-args-port pending-error ] keep [ parse-WSARecvFrom ]
parse-WSARecvFrom } cleave
] with-destructors ; ] with-destructors ;
TUPLE: WSASendTo-args port TUPLE: WSASendTo-args port
@ -206,49 +139,33 @@ TUPLE: WSASendTo-args port
dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ; dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ;
: make-send-buffer ( packet -- WSABUF ) : make-send-buffer ( packet -- WSABUF )
"WSABUF" malloc-object dup free-always "WSABUF" malloc-object &free
over malloc-byte-array dup free-always over set-WSABUF-buf [ >r malloc-byte-array &free r> set-WSABUF-buf ]
swap length over set-WSABUF-len ; [ >r length r> set-WSABUF-len ]
[ nip ]
2tri ;
: init-WSASendTo ( packet addrspec datagram WSASendTo -- ) : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
[ set-WSASendTo-args-port ] 2keep WSASendTo-args new
[ swap >>port
>r port-handle win32-file-handle r> set-WSASendTo-args-s* dup port>> handle>> handle>> >>s*
] keep swap make-sockaddr/size
[ >r malloc-byte-array &free
>r make-sockaddr/size >r r> [ >>lpTo* ] [ >>iToLen* ] bi*
malloc-byte-array dup free-always swap make-send-buffer >>lpBuffers*
r> r> 1 >>dwBufferCount*
[ set-WSASendTo-args-iToLen* ] keep 0 >>dwFlags*
set-WSASendTo-args-lpTo* 0 <uint> >>lpNumberOfBytesSent*
] keep (make-overlapped) >>lpOverlapped* ;
[
>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 ;
: call-WSASendTo ( WSASendTo -- ) : call-WSASendTo ( WSASendTo -- )
\ WSASendTo-args >tuple*< WSASendTo-args >tuple*< WSASendTo socket-error* ;
WSASendTo socket-error* ;
USE: io.sockets M: winnt (send) ( packet addrspec datagram -- )
M: winnt send ( packet addrspec datagram -- )
[ [
check-datagram-send <WSASendTo-args>
\ WSASendTo-args new [ call-WSASendTo ]
[ init-WSASendTo ] keep [ wait-for-socket drop ]
[ call-WSASendTo ] keep [ port>> pending-error ]
[ WSASendTo-continuation ] keep tri
WSASendTo-args-port pending-error
] with-destructors ; ] with-destructors ;

8
extra/io/windows/privileges/privileges.factor Executable file
View File

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

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

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

198
extra/io/windows/windows.factor
View File

@ -8,18 +8,33 @@ windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields system accessors ; continuations math.bitfields system accessors ;
IN: io.windows 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: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- ) HOOK: add-completion io-backend ( port -- )
M: windows normalize-directory ( string -- string ) : opened-file ( handle -- win32-file )
normalize-path "\\" ?tail drop "\\*" append ; dup invalid-handle?
<win32-file> |dispose
dup add-completion ;
: share-mode ( -- fixnum ) : share-mode ( -- fixnum )
{ {
@ -36,176 +51,3 @@ M: windows normalize-directory ( string -- string )
: security-attributes-inherit ( -- obj ) : security-attributes-inherit ( -- obj )
default-security-attributes default-security-attributes
TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable 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 ;

7
extra/openssl/libssl/libssl.factor
View File

@ -122,6 +122,13 @@ FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ;
FUNCTION: void SSL_free ( ssl-pointer ssl ) ; FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
FUNCTION: int SSL_want ( ssl-pointer ssl ) ;
: SSL_NOTHING 1 ; inline
: SSL_WRITING 2 ; inline
: SSL_READING 3 ; inline
: SSL_X509_LOOKUP 4 ; inline
FUNCTION: long SSL_get_verify_result ( SSL* ssl ) ; FUNCTION: long SSL_get_verify_result ( SSL* ssl ) ;
FUNCTION: X509* SSL_get_peer_certificate ( SSL* s ) ; FUNCTION: X509* SSL_get_peer_certificate ( SSL* s ) ;

2
extra/windows/winsock/winsock.factor Normal file → Executable file
View File

@ -167,6 +167,8 @@ FUNCTION: int shutdown ( SOCKET s, int how ) ;
FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ; FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
FUNCTION: int recv ( 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: uint SERVICETYPE
TYPEDEF: OVERLAPPED WSAOVERLAPPED TYPEDEF: OVERLAPPED WSAOVERLAPPED
TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED