diff --git a/core/libc/libc-tests.factor b/core/libc/libc-tests.factor
new file mode 100755
index 0000000000..249399bdd0
--- /dev/null
+++ b/core/libc/libc-tests.factor
@@ -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
diff --git a/core/libc/libc.factor b/core/libc/libc.factor
index cba0b9253f..dff6e9e0f1 100755
--- a/core/libc/libc.factor
+++ b/core/libc/libc.factor
@@ -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
diff --git a/extra/io/mmap/mmap-docs.factor b/extra/io/mmap/mmap-docs.factor
index 0c8148d6b0..4ac85232b8 100755
--- a/extra/io/mmap/mmap-docs.factor
+++ b/extra/io/mmap/mmap-docs.factor
@@ -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." }
diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor
index da3ed38688..d25097e2b0 100755
--- a/extra/io/mmap/mmap-tests.factor
+++ b/extra/io/mmap/mmap-tests.factor
@@ -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
diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor
index 40f6c22b82..36a0559bdb 100755
--- a/extra/io/sockets/sockets.factor
+++ b/extra/io/sockets/sockets.factor
@@ -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 )
diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor
index 14ad49a89a..c31e23849e 100755
--- a/extra/io/unix/mmap/mmap.factor
+++ b/extra/io/unix/mmap/mmap.factor
@@ -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 ]
diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor
index bc328a146f..b4381de43b 100644
--- a/extra/io/unix/sockets/secure/secure.factor
+++ b/extra/io/unix/sockets/secure/secure.factor
@@ -9,10 +9,6 @@ io.encodings.ascii io.buffers io.sockets io.sockets.secure
unix system ;
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 ;
: syscall-error ( r -- * )
@@ -78,6 +74,8 @@ M: ssl ((client)) ( addrspec -- handle )
M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
+M: ssl (get-local-address) addrspec>> (get-local-address) ;
+
: check-connect-response ( port r -- event )
check-response
{
@@ -88,15 +86,15 @@ M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;
-: do-ssl-connect ( port ssl-handle -- )
- 2dup SSL_connect check-connect-response dup
- [ >r over r> wait-for-port do-ssl-connect ] [ 3drop ] if ;
+: do-ssl-connect ( port -- )
+ dup dup handle>> handle>> SSL_connect
+ check-connect-response dup
+ [ dupd wait-for-port do-ssl-connect ] [ 2drop ] if ;
M: ssl establish-connection ( client-out remote -- )
- addrspec>>
- [ establish-connection ]
- [ drop dup handle>> do-ssl-connect ]
- [ drop t >>connected drop ]
+ [ addrspec>> establish-connection ]
+ [ drop do-ssl-connect ]
+ [ drop handle>> t >>connected drop ]
2tri ;
M: ssl (server) addrspec>> (server) ;
@@ -122,16 +120,29 @@ M: ssl (accept)
] with-destructors ;
: 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+ ] }
- { SSL_ERROR_WANT_WRITE [ +output+ ] }
- { SSL_ERROR_SYSCALL [ -1 syscall-error ] }
- { SSL_ERROR_SSL [ (ssl-error) ] }
+ { 1 [ drop f ] }
+ { 0 [
+ dup SSL_want {
+ { 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 ;
M: unix ssl-shutdown
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
] [ drop ] if ;
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
old mode 100644
new mode 100755
index 910f87a163..0bb0e3405a
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -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
] [
diff --git a/extra/io/windows/ce/privileges/privileges.factor b/extra/io/windows/ce/privileges/privileges.factor
new file mode 100755
index 0000000000..e0aa186b3d
--- /dev/null
+++ b/extra/io/windows/ce/privileges/privileges.factor
@@ -0,0 +1,4 @@
+IN: io.windows.ce.privileges
+USING: io.windows.privileges system ;
+
+M: wince set-privilege 2drop ;
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index ed6ca0bc54..ef3db0dcd1 100755
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -1,11 +1,121 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types io.backend io.files io.windows kernel math
+USING: alien.c-types io.binary io.backend io.files io.buffers
+io.windows kernel math splitting
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces words symbols system
-combinators.lib io.ports destructors math.bitfields.lib ;
+combinators.lib io.ports destructors accessors
+math.bitfields math.bitfields.lib ;
IN: io.windows.files
+: open-file ( path access-mode create-mode flags -- handle )
+ [
+ >r >r share-mode security-attributes-inherit r> r>
+ CreateFile-flags f CreateFile opened-file
+ ] with-destructors ;
+
+: open-pipe-r/w ( path -- win32-file )
+ { GENERIC_READ GENERIC_WRITE } flags
+ OPEN_EXISTING 0 open-file ;
+
+: open-read ( path -- win32-file )
+ GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
+
+: open-write ( path -- win32-file )
+ GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
+
+: (open-append) ( path -- win32-file )
+ GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
+
+: open-existing ( path -- win32-file )
+ { GENERIC_READ GENERIC_WRITE } flags
+ share-mode
+ f
+ OPEN_EXISTING
+ FILE_FLAG_BACKUP_SEMANTICS
+ f CreateFileW dup win32-error=0/f <win32-file> ;
+
+: maybe-create-file ( path -- win32-file ? )
+ #! return true if file was just created
+ { GENERIC_READ GENERIC_WRITE } flags
+ share-mode
+ f
+ OPEN_ALWAYS
+ 0 CreateFile-flags
+ f CreateFileW dup win32-error=0/f <win32-file>
+ GetLastError ERROR_ALREADY_EXISTS = not ;
+
+: set-file-pointer ( handle length method -- )
+ >r dupd d>w/w <uint> r> SetFilePointer
+ INVALID_SET_FILE_POINTER = [
+ CloseHandle "SetFilePointer failed" throw
+ ] when drop ;
+
+HOOK: open-append os ( path -- win32-file )
+
+TUPLE: FileArgs
+ hFile lpBuffer nNumberOfBytesToRead
+ lpNumberOfBytesRet lpOverlapped ;
+
+C: <FileArgs> FileArgs
+
+: make-FileArgs ( port -- <FileArgs> )
+ {
+ [ handle>> handle>> ]
+ [ buffer>> ]
+ [ buffer>> buffer-length ]
+ [ drop "DWORD" <c-object> ]
+ [ FileArgs-overlapped ]
+ } cleave <FileArgs> ;
+
+: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
+ {
+ [ hFile>> ]
+ [ lpBuffer>> buffer-end ]
+ [ lpBuffer>> buffer-capacity ]
+ [ lpNumberOfBytesRet>> ]
+ [ lpOverlapped>> ]
+ } cleave ;
+
+: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
+ {
+ [ hFile>> ]
+ [ lpBuffer>> buffer@ ]
+ [ lpBuffer>> buffer-length ]
+ [ lpNumberOfBytesRet>> ]
+ [ lpOverlapped>> ]
+ } cleave ;
+
+M: windows (file-reader) ( path -- stream )
+ open-read <input-port> ;
+
+M: windows (file-writer) ( path -- stream )
+ open-write <output-port> ;
+
+M: windows (file-appender) ( path -- stream )
+ open-append <output-port> ;
+
+M: windows move-file ( from to -- )
+ [ normalize-path ] bi@ MoveFile win32-error=0/f ;
+
+M: windows delete-file ( path -- )
+ normalize-path DeleteFile win32-error=0/f ;
+
+M: windows copy-file ( from to -- )
+ dup parent-directory make-directories
+ [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
+
+M: windows make-directory ( path -- )
+ normalize-path
+ f CreateDirectory win32-error=0/f ;
+
+M: windows delete-directory ( path -- )
+ normalize-path
+ RemoveDirectory win32-error=0/f ;
+
+M: windows normalize-directory ( string -- string )
+ normalize-path "\\" ?tail drop "\\*" append ;
+
SYMBOLS: +read-only+ +hidden+ +system+
+archive+ +device+ +normal+ +temporary+
+sparse-file+ +reparse-point+ +compressed+ +offline+
@@ -101,7 +211,7 @@ M: winnt link-info ( path -- info )
: file-times ( path -- timestamp timestamp timestamp )
[
- normalize-path open-existing dup close-always
+ normalize-path open-existing &dispose handle>>
"FILETIME" <c-object>
"FILETIME" <c-object>
"FILETIME" <c-object>
@@ -117,7 +227,7 @@ M: winnt link-info ( path -- info )
#! timestamp order: creation access write
[
>r >r >r
- normalize-path open-existing dup close-always
+ normalize-path open-existing &dispose handle>>
r> r> r> (set-file-times)
] with-destructors ;
@@ -133,6 +243,6 @@ M: winnt link-info ( path -- info )
M: winnt touch-file ( path -- )
[
normalize-path
- maybe-create-file over close-always
- [ drop ] [ f now dup (set-file-times) ] if
+ maybe-create-file >r &dispose r>
+ [ drop ] [ handle>> f now dup (set-file-times) ] if
] with-destructors ;
diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor
old mode 100644
new mode 100755
index 2c166373e7..dcb713df7f
--- a/extra/io/windows/files/unique/unique.factor
+++ b/extra/io/windows/files/unique/unique.factor
@@ -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 ;
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 28e7e241e5..1cfb91d716 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -6,7 +6,7 @@ windows.types math windows.kernel32
namespaces io.launcher kernel sequences windows.errors
splitting system threads init strings combinators
io.backend accessors concurrency.flags io.files assocs
-io.files.private windows destructors ;
+io.files.private windows destructors classes.tuple.lib ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
@@ -19,8 +19,7 @@ TUPLE: CreateProcess-args
lpEnvironment
lpCurrentDirectory
lpStartupInfo
- lpProcessInformation
- stdout-pipe stdin-pipe ;
+ lpProcessInformation ;
: default-CreateProcess-args ( -- obj )
CreateProcess-args new
@@ -31,18 +30,7 @@ TUPLE: CreateProcess-args
0 >>dwCreateFlags ;
: call-CreateProcess ( CreateProcess-args -- )
- {
- lpApplicationName>>
- lpCommandLine>>
- lpProcessAttributes>>
- lpThreadAttributes>>
- bInheritHandles>>
- dwCreateFlags>>
- lpEnvironment>>
- lpCurrentDirectory>>
- lpStartupInfo>>
- lpProcessInformation>>
- } get-slots CreateProcess win32-error=0/f ;
+ CreateProcess-args >tuple< CreateProcess win32-error=0/f ;
: count-trailing-backslashes ( str n -- str n )
>r "\\" ?tail [
diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor
index b401ed5556..72dfca9df3 100755
--- a/extra/io/windows/mmap/mmap.factor
+++ b/extra/io/windows/mmap/mmap.factor
@@ -1,88 +1,44 @@
-USING: alien alien.c-types alien.syntax arrays continuations
-destructors generic io.mmap io.ports io.windows
-kernel libc math namespaces quotations sequences windows
-windows.advapi32 windows.kernel32 io.backend system ;
+USING: alien alien.c-types arrays destructors generic io.mmap
+io.ports io.windows io.windows.files io.windows.privileges
+kernel libc math math.bitfields namespaces quotations sequences
+windows windows.advapi32 windows.kernel32 io.backend system
+accessors locals ;
IN: io.windows.mmap
-TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
+: create-file-mapping
+ CreateFileMapping [ win32-error=0/f ] keep <win32-handle> ;
-! Security tokens
-! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
+: map-view-of-file
+ MapViewOfFile [ win32-error=0/f ] keep ;
-: (open-process-token) ( handle -- handle )
- TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY bitor "PHANDLE" <c-object>
- [ OpenProcessToken win32-error=0/f ] keep *void* ;
+:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
+ [let | lo [ length HEX: ffffffff bitand ]
+ hi [ length -32 shift HEX: ffffffff bitand ] |
+ { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
+ path access-mode create-mode 0 open-file |dispose
+ dup handle>> f protect hi lo f create-file-mapping |dispose
+ dup handle>> access 0 0 0 map-view-of-file
+ ] with-privileges
+ ] ;
-: open-process-token ( -- handle )
- #! remember to handle-close this
- GetCurrentProcess (open-process-token) ;
+TUPLE: win32-mapped-file file mapping ;
-: with-process-token ( quot -- )
- #! quot: ( token-handle -- token-handle )
- >r open-process-token r>
- [ keep ] curry
- [ CloseHandle drop ] [ ] cleanup ; inline
+M: win32-mapped-file dispose
+ [ file>> dispose ] [ mapping>> dispose ] bi ;
-: lookup-privilege ( string -- luid )
- >r f r> "LUID" <c-object>
- [ LookupPrivilegeValue win32-error=0/f ] keep ;
+C: <win32-mapped-file> win32-mapped-file
-: make-token-privileges ( name ? -- obj )
- "TOKEN_PRIVILEGES" <c-object>
- 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep
- "LUID_AND_ATTRIBUTES" malloc-array
- dup free-always over set-TOKEN_PRIVILEGES-Privileges
-
- swap [
- SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
- set-LUID_AND_ATTRIBUTES-Attributes
- ] when
-
- >r lookup-privilege r>
+M: windows (mapped-file)
[
- TOKEN_PRIVILEGES-Privileges
- >r 0 r> LUID_AND_ATTRIBUTES-nth
- set-LUID_AND_ATTRIBUTES-Luid
- ] keep ;
-
-: set-privilege ( name ? -- )
- [
- -rot 0 -rot make-token-privileges
- dup length f f AdjustTokenPrivileges win32-error=0/f
- ] with-process-token ;
-
-HOOK: with-privileges io-backend ( seq quot -- ) inline
-
-M: winnt with-privileges
- over [ [ t set-privilege ] each ] curry compose
- swap [ [ f set-privilege ] each ] curry [ ] cleanup ;
-
-M: wince with-privileges
- nip call ;
-
-: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
- { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
- >r >r 0 open-file dup f r> 0 0 f
- CreateFileMapping [ win32-error=0/f ] keep
- dup close-later
- dup
- r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep
- dup close-later
- ] with-privileges ;
-
-M: windows (mapped-file) ( path length -- mmap )
- [
- swap
- GENERIC_WRITE GENERIC_READ bitor
+ { GENERIC_WRITE GENERIC_READ } flags
OPEN_ALWAYS
- PAGE_READWRITE SEC_COMMIT bitor
+ { PAGE_READWRITE SEC_COMMIT } flags
FILE_MAP_ALL_ACCESS mmap-open
- -rot 2array
- f \ mapped-file boa
+ -rot <win32-mapped-file>
] with-destructors ;
M: windows close-mapped-file ( mapped-file -- )
[
- dup mapped-file-handle [ close-always ] each
- mapped-file-address UnmapViewOfFile win32-error=0/f
+ [ handle>> &dispose drop ]
+ [ address>> UnmapViewOfFile win32-error=0/f ] bi
] with-destructors ;
diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor
index 99364f832d..134a0c024a 100755
--- a/extra/io/windows/nt/backend/backend.factor
+++ b/extra/io/windows/nt/backend/backend.factor
@@ -1,9 +1,10 @@
USING: alien alien.c-types arrays assocs combinators
-continuations destructors io io.backend io.ports
-io.windows libc kernel math namespaces sequences
-threads classes.tuple.lib windows windows.errors
-windows.kernel32 strings splitting io.files qualified ascii
-combinators.lib system accessors ;
+continuations destructors io io.backend io.ports io.timeouts
+io.windows io.windows.files libc kernel math namespaces
+sequences threads classes.tuple.lib windows windows.errors
+windows.kernel32 strings splitting io.files
+io.buffers qualified ascii combinators.lib system
+accessors locals ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
@@ -14,11 +15,11 @@ TUPLE: io-callback port thread ;
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
- "OVERLAPPED" malloc-object dup free-always ;
+ "OVERLAPPED" malloc-object &free ;
: make-overlapped ( port -- overlapped-ext )
- >r (make-overlapped) r> port-handle win32-file-ptr
- [ over set-OVERLAPPED-offset ] when* ;
+ >r (make-overlapped)
+ r> handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
: <completion-port> ( handle existing -- handle )
f 1 CreateIoCompletionPort dup win32-error=0/f ;
@@ -28,8 +29,8 @@ SYMBOL: master-completion-port
: <master-completion-port> ( -- handle )
INVALID_HANDLE_VALUE f <completion-port> ;
-M: winnt add-completion ( handle -- )
- master-completion-port get-global <completion-port> drop ;
+M: winnt add-completion ( win32-handle -- )
+ handle>> master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? )
dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ;
@@ -56,13 +57,21 @@ M: winnt add-completion ( handle -- )
io-hash get-global set-at
] "I/O" suspend 3drop ;
-: wait-for-overlapped ( ms -- overlapped ? )
- >r master-completion-port get-global
- r> INFINITE or ! timeout
+: twiddle-thumbs ( overlapped port -- bytes-transferred )
+ [ save-callback ]
+ [ get-overlapped-result ]
+ [ nip pending-error ]
+ 2tri ;
+
+:: wait-for-overlapped ( ms -- overlapped ? )
+ master-completion-port get-global
0 <int> ! bytes
f <void*> ! key
f <void*> ! overlapped
- [ roll GetQueuedCompletionStatus ] keep *void* swap zero? ;
+ [
+ ms INFINITE or ! timeout
+ GetQueuedCompletionStatus
+ ] keep *void* swap zero? ;
: lookup-callback ( overlapped -- callback )
io-hash get-global delete-at* drop
@@ -70,32 +79,64 @@ M: winnt add-completion ( handle -- )
: handle-overlapped ( timeout -- ? )
wait-for-overlapped [
- GetLastError dup expected-io-error? [
- 2drop t
- ] [
- dup eof? [
- drop lookup-callback
- dup port>> t >>eof drop
- ] [
- (win32-error-string) swap lookup-callback
- [ port>> set-port-error ] keep
- ] if thread>> resume f
+ GetLastError dup expected-io-error? [ 2drop f ] [
+ >r lookup-callback [ thread>> ] [ port>> ] bi r>
+ dup eof?
+ [ drop t >>eof ]
+ [ (win32-error-string) >>error ] if drop
+ resume t
] if
] [
lookup-callback
- io-callback-thread resume f
+ thread>> resume t
] if ;
-: drain-overlapped ( timeout -- )
- handle-overlapped [ 0 drain-overlapped ] unless ;
-
M: winnt cancel-io
handle>> handle>> CancelIo drop ;
M: winnt io-multiplex ( ms -- )
- drain-overlapped ;
+ handle-overlapped [ 0 io-multiplex ] when ;
M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
H{ } clone io-hash set-global
windows.winsock:init-winsock ;
+
+: update-file-ptr ( n port -- )
+ handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
+
+: finish-flush ( n port -- )
+ [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
+
+: ((wait-to-write)) ( port -- )
+ dup make-FileArgs
+ tuck setup-write WriteFile
+ dupd overlapped-error? [
+ >r lpOverlapped>> r>
+ [ twiddle-thumbs ] keep
+ [ finish-flush ] keep
+ dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if
+ ] [
+ 2drop
+ ] if ;
+
+M: winnt (wait-to-write)
+ [ [ ((wait-to-write)) ] with-timeout ] with-destructors ;
+
+: finish-read ( n port -- )
+ over zero? [
+ t >>eof 2drop
+ ] [
+ [ buffer>> n>buffer ] [ update-file-ptr ] 2bi
+ ] if ;
+
+: ((wait-to-read)) ( port -- )
+ dup make-FileArgs
+ tuck setup-read ReadFile
+ dupd overlapped-error? [
+ >r lpOverlapped>> r>
+ [ twiddle-thumbs ] [ finish-read ] bi
+ ] [ 2drop ] if ;
+
+M: winnt (wait-to-read) ( port -- )
+ [ [ ((wait-to-read)) ] with-timeout ] with-destructors ;
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 2b3021a3f1..67161716a3 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -1,6 +1,7 @@
USING: continuations destructors io.buffers io.files io.backend
-io.timeouts io.ports io.windows io.windows.nt.backend
-kernel libc math threads windows windows.kernel32 system
+io.timeouts io.ports io.windows io.windows.files
+io.windows.nt.backend windows windows.kernel32
+kernel libc math threads system
alien.c-types alien.arrays alien.strings sequences combinators
combinators.lib sequences.lib ascii splitting alien strings
assocs namespaces io.files.private accessors ;
@@ -29,6 +30,7 @@ M: winnt root-directory? ( path -- ? )
} cond nip ;
ERROR: not-absolute-path ;
+
: root-directory ( string -- string' )
{
[ dup length 2 >= ]
@@ -54,57 +56,4 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
M: winnt open-append
[ dup file-info size>> ] [ drop 0 ] recover
- >r (open-append) r> ;
-
-: update-file-ptr ( n port -- )
- port-handle
- dup win32-file-ptr [
- rot + swap set-win32-file-ptr
- ] [
- 2drop
- ] if* ;
-
-: finish-flush ( overlapped port -- )
- dup pending-error
- tuck get-overlapped-result
- dup pick update-file-ptr
- swap buffer>> buffer-consume ;
-
-: (flush-output) ( port -- )
- dup make-FileArgs
- tuck setup-write WriteFile
- dupd overlapped-error? [
- >r FileArgs-lpOverlapped r>
- [ save-callback ] 2keep
- [ finish-flush ] keep
- dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if
- ] [
- 2drop
- ] if ;
-
-: flush-output ( port -- )
- [ [ (flush-output) ] with-timeout ] with-destructors ;
-
-M: winnt flush-port
- dup buffer>> buffer-empty? [ dup flush-output ] unless drop ;
-
-: finish-read ( overlapped port -- )
- dup pending-error
- tuck get-overlapped-result dup zero? [
- drop t >>eof drop
- ] [
- dup pick buffer>> n>buffer
- swap update-file-ptr
- ] if ;
-
-: ((wait-to-read)) ( port -- )
- dup make-FileArgs
- tuck setup-read ReadFile
- dupd overlapped-error? [
- >r FileArgs-lpOverlapped r>
- [ save-callback ] 2keep
- finish-read
- ] [ 2drop ] if ;
-
-M: winnt (wait-to-read) ( port -- )
- [ [ ((wait-to-read)) ] with-timeout ] with-destructors ;
+ >r (open-append) r> >>ptr ;
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index c18523e68d..6c86b53049 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -4,8 +4,9 @@ USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.ports io.pipes windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings
-io.windows.launcher io.windows.nt.pipes io.backend io.files
-io.files.private combinators shuffle accessors locals ;
+io.windows.launcher io.windows.files
+io.backend io.files io.files.private combinators shuffle
+accessors locals ;
IN: io.windows.nt.launcher
: duplicate-handle ( handle -- handle' )
@@ -21,10 +22,10 @@ IN: io.windows.nt.launcher
! /dev/null simulation
: null-input ( -- pipe )
- (pipe) [ in>> handle>> ] [ out>> close-handle ] bi ;
+ (pipe) [ in>> handle>> ] [ out>> dispose ] bi ;
: null-output ( -- pipe )
- (pipe) [ in>> close-handle ] [ out>> handle>> ] bi ;
+ (pipe) [ in>> dispose ] [ out>> handle>> ] bi ;
: null-pipe ( mode -- pipe )
{
@@ -35,13 +36,13 @@ IN: io.windows.nt.launcher
! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
-: redirect-default ( default obj access-mode create-mode -- handle )
- 3drop ;
+: redirect-default ( obj access-mode create-mode -- handle )
+ 3drop f ;
-: redirect-closed ( default obj access-mode create-mode -- handle )
- drop 2nip null-pipe ;
+: redirect-closed ( obj access-mode create-mode -- handle )
+ drop nip null-pipe ;
-:: redirect-file ( default path access-mode create-mode -- handle )
+:: redirect-file ( path access-mode create-mode -- handle )
path normalize-path
access-mode
share-mode
@@ -49,9 +50,9 @@ IN: io.windows.nt.launcher
create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
- CreateFile dup invalid-handle? dup close-always ;
+ CreateFile dup invalid-handle? <win32-file> &dispose handle>> ;
-: redirect-append ( default path access-mode create-mode -- handle )
+: redirect-append ( path access-mode create-mode -- handle )
>r >r path>> r> r>
drop OPEN_ALWAYS
redirect-file
@@ -60,14 +61,13 @@ IN: io.windows.nt.launcher
: set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
-: redirect-handle ( default handle access-mode create-mode -- handle )
- 2drop nip
- handle>> duplicate-handle dup t set-inherit ;
+: redirect-handle ( handle access-mode create-mode -- handle )
+ 2drop handle>> duplicate-handle dup t set-inherit ;
-: redirect-stream ( default stream access-mode create-mode -- handle )
- >r >r underlying-handle r> r> redirect-handle ;
+: redirect-stream ( stream access-mode create-mode -- handle )
+ >r >r underlying-handle handle>> r> r> redirect-handle ;
-: redirect ( default obj access-mode create-mode -- handle )
+: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick not ] [ redirect-default ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
@@ -77,12 +77,9 @@ IN: io.windows.nt.launcher
[ redirect-stream ]
} cond ;
-: default-stdout ( args -- handle )
- stdout-pipe>> dup [ out>> ] when ;
-
: redirect-stdout ( process args -- handle )
- default-stdout
- swap stdout>>
+ drop
+ stdout>>
GENERIC_WRITE
CREATE_ALWAYS
redirect
@@ -90,25 +87,20 @@ IN: io.windows.nt.launcher
: redirect-stderr ( process args -- handle )
over stderr>> +stdout+ eq? [
- lpStartupInfo>>
- STARTUPINFO-hStdOutput
nip
+ lpStartupInfo>> STARTUPINFO-hStdOutput
] [
drop
- f
- swap stderr>>
+ stderr>>
GENERIC_WRITE
CREATE_ALWAYS
redirect
STD_ERROR_HANDLE GetStdHandle or
] if ;
-: default-stdin ( args -- handle )
- stdin-pipe>> dup [ in>> ] when ;
-
: redirect-stdin ( process args -- handle )
- default-stdin
- swap stdin>>
+ drop
+ stdin>>
GENERIC_READ
OPEN_EXISTING
redirect
diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor
index ee8c6c60e1..a509d1d5e7 100755
--- a/extra/io/windows/nt/monitors/monitors.factor
+++ b/extra/io/windows/nt/monitors/monitors.factor
@@ -17,11 +17,7 @@ IN: io.windows.nt.monitors
OPEN_EXISTING
{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
f
- CreateFile
- dup invalid-handle?
- dup close-later
- dup add-completion
- f <win32-file> ;
+ CreateFile opened-file ;
TUPLE: win32-monitor-port < input-port recursive ;
@@ -41,11 +37,7 @@ TUPLE: win32-monitor < monitor port ;
: read-changes ( port -- bytes )
[
- dup begin-reading-changes
- swap [ save-callback ] 2keep
- check-closed ! we may have closed it...
- dup eof>> [ "EOF??" throw ] when
- get-overlapped-result
+ [ begin-reading-changes ] [ twiddle-thumbs ] bi
] with-destructors ;
: parse-action ( action -- changed )
@@ -87,7 +79,7 @@ TUPLE: win32-monitor < monitor port ;
] each ;
: fill-queue ( monitor -- )
- dup port>> check-closed
+ dup port>> dup check-disposed
[ buffer>> ptr>> ] [ read-changes zero? ] bi
[ 2dup parse-notify-records ] unless
2drop ;
@@ -97,7 +89,7 @@ TUPLE: win32-monitor < monitor port ;
: fill-queue-thread ( monitor -- )
[ dup fill-queue (fill-queue-thread) ]
- [ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ;
+ [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ;
M:: winnt (monitor) ( path recursive? mailbox -- monitor )
[
diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor
index 33bb3a88b9..8e59a4d555 100755
--- a/extra/io/windows/nt/nt.factor
+++ b/extra/io/windows/nt/nt.factor
@@ -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
diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor
index 8a0fa05b74..97c2e49627 100755
--- a/extra/io/windows/nt/pipes/pipes.factor
+++ b/extra/io/windows/nt/pipes/pipes.factor
@@ -17,10 +17,7 @@ IN: io.windows.nt.pipes
4096
0
security-attributes-inherit
- CreateNamedPipe
- dup win32-error=0/f
- dup add-completion
- f <win32-file> ;
+ CreateNamedPipe opened-file ;
: open-other-end ( name -- handle )
GENERIC_WRITE
@@ -29,10 +26,7 @@ IN: io.windows.nt.pipes
OPEN_EXISTING
FILE_FLAG_OVERLAPPED
f
- CreateFile
- dup win32-error=0/f
- dup add-completion
- f <win32-file> ;
+ CreateFile opened-file ;
: unique-pipe-name ( -- string )
[
@@ -47,7 +41,6 @@ IN: io.windows.nt.pipes
M: winnt (pipe) ( -- pipe )
[
unique-pipe-name
- [ create-named-pipe dup close-later ]
- [ open-other-end dup close-later ]
- bi pipe boa
+ [ create-named-pipe ] [ open-other-end ] bi
+ pipe boa
] with-destructors ;
diff --git a/extra/io/windows/nt/privileges/privileges.factor b/extra/io/windows/nt/privileges/privileges.factor
new file mode 100755
index 0000000000..007d05f9af
--- /dev/null
+++ b/extra/io/windows/nt/privileges/privileges.factor
@@ -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 ;
diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor
index 5baa0a31e5..75a08a02c4 100755
--- a/extra/io/windows/nt/sockets/sockets.factor
+++ b/extra/io/windows/nt/sockets/sockets.factor
@@ -1,8 +1,9 @@
USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.ports io.timeouts io.sockets
io.sockets io namespaces io.streams.duplex io.windows
+io.windows.sockets
io.windows.nt.backend windows.winsock kernel libc math sequences
-threads classes.tuple.lib system accessors ;
+threads classes.tuple.lib system combinators accessors ;
IN: io.windows.nt.sockets
: malloc-int ( object -- object )
@@ -30,121 +31,68 @@ TUPLE: ConnectEx-args port
s* name* namelen* lpSendBuffer* dwSendDataLength*
lpdwBytesSent* lpOverlapped* ptr* ;
-: init-connect ( sockaddr size ConnectEx -- )
- [ set-ConnectEx-args-namelen* ] keep
- [ set-ConnectEx-args-name* ] keep
- f over set-ConnectEx-args-lpSendBuffer*
- 0 over set-ConnectEx-args-dwSendDataLength*
- f over set-ConnectEx-args-lpdwBytesSent*
- (make-overlapped) swap set-ConnectEx-args-lpOverlapped* ;
+: wait-for-socket ( args -- n )
+ [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
-: (ConnectEx) ( ConnectEx -- )
- \ ConnectEx-args >tuple*<
+: <ConnectEx-args> ( sockaddr size -- ConnectEx )
+ ConnectEx-args new
+ swap >>namelen*
+ swap >>name*
+ f >>lpSendBuffer*
+ 0 >>dwSendDataLength*
+ f >>lpdwBytesSent*
+ (make-overlapped) >>lpOverlapped* ;
+
+: call-ConnectEx ( ConnectEx -- )
+ ConnectEx-args >tuple*<
"int"
{ "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
"stdcall" alien-indirect drop
winsock-error-string [ throw ] when* ;
-: connect-continuation ( overlapped port -- )
- 2dup save-callback
- get-overlapped-result drop ;
-
-M: win32-socket wait-to-connect ( client-out handle -- )
- [ overlapped>> swap connect-continuation ]
- [ drop pending-error ]
- 2bi ;
-
-M: object ((client)) ( addrspec -- handle )
- [
- \ ConnectEx-args new
- over make-sockaddr/size pick init-connect
- over tcp-socket over set-ConnectEx-args-s*
- dup ConnectEx-args-s* add-completion
- dup ConnectEx-args-s* get-ConnectEx-ptr over set-ConnectEx-args-ptr*
- dup ConnectEx-args-s* INADDR_ANY roll bind-socket
- dup (ConnectEx)
-
- dup [ ConnectEx-args-s* ] [ ConnectEx-args-lpOverlapped* ] bi <win32-socket>
- ] with-destructors ;
+M: object establish-connection ( client-out remote -- )
+ make-sockaddr/size <ConnectEx-args>
+ swap >>port
+ dup port>> handle>> handle>> >>s*
+ dup s*>> get-ConnectEx-ptr >>ptr*
+ dup call-ConnectEx
+ wait-for-socket drop ;
TUPLE: AcceptEx-args port
sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ;
-: init-accept-buffer ( server-port AcceptEx -- )
- >r server-port-addr sockaddr-type heap-size 16 +
- dup dup 2 * malloc dup free-always r>
- [ set-AcceptEx-args-lpOutputBuffer* ] keep
- [ set-AcceptEx-args-dwLocalAddressLength* ] keep
- set-AcceptEx-args-dwRemoteAddressLength* ;
+: init-accept-buffer ( addr AcceptEx -- )
+ swap sockaddr-type heap-size 16 +
+ [ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi
+ dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer*
+ drop ;
-: init-accept ( server-port AcceptEx -- )
- [ init-accept-buffer ] 2keep
- [ set-AcceptEx-args-port ] 2keep
- >r port-handle win32-file-handle r> [ set-AcceptEx-args-sListenSocket* ] keep
- dup AcceptEx-args-port server-port-addr tcp-socket
- over set-AcceptEx-args-sAcceptSocket*
- 0 over set-AcceptEx-args-dwReceiveDataLength*
- f over set-AcceptEx-args-lpdwBytesReceived*
- (make-overlapped) swap set-AcceptEx-args-lpOverlapped* ;
+: <AcceptEx-args> ( server addr -- AcceptEx )
+ AcceptEx-args new
+ 2dup init-accept-buffer
+ swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket*
+ over handle>> handle>> >>sListenSocket*
+ swap >>port
+ 0 >>dwReceiveDataLength*
+ f >>lpdwBytesReceived*
+ (make-overlapped) >>lpOverlapped* ;
-: ((accept)) ( AcceptEx -- )
- \ AcceptEx-args >tuple*<
- AcceptEx drop
+: call-AcceptEx ( AcceptEx -- )
+ AcceptEx-args >tuple*< AcceptEx drop
winsock-error-string [ throw ] when* ;
-: make-accept-continuation ( AcceptEx -- )
- dup AcceptEx-args-lpOverlapped*
- swap AcceptEx-args-port save-callback ;
-
-: check-accept-error ( AcceptEx -- )
- dup AcceptEx-args-lpOverlapped*
- swap AcceptEx-args-port get-overlapped-result drop ;
-
-: extract-remote-host ( AcceptEx -- addrspec )
- [
- [ AcceptEx-args-lpOutputBuffer* ] keep
- [ AcceptEx-args-dwReceiveDataLength* ] keep
- [ AcceptEx-args-dwLocalAddressLength* ] keep
- AcceptEx-args-dwRemoteAddressLength*
- f <void*>
- 0 <int>
- f <void*> [
- 0 <int> GetAcceptExSockaddrs
- ] keep *void*
- ] keep AcceptEx-args-port server-port-addr parse-sockaddr ;
-
-: accept-continuation ( AcceptEx -- addrspec client )
- [ make-accept-continuation ] keep
- [ check-accept-error ] keep
- [ extract-remote-host ] keep
- ! addrspec AcceptEx
- [ AcceptEx-args-sAcceptSocket* add-completion ] keep
- [ AcceptEx-args-sAcceptSocket* ] [ AcceptEx-args-lpOverlapped* ] bi <win32-socket> ;
-
-M: winnt (accept) ( server -- addrspec handle )
+M: object (accept) ( server addr -- handle )
[
[
- \ AcceptEx-args new
- [ init-accept ] keep
- [ ((accept)) ] keep
- [ accept-continuation ] keep
- AcceptEx-args-port pending-error
- ] with-timeout
- ] with-destructors ;
-
-M: winnt (server) ( addrspec -- handle )
- [
- SOCK_STREAM server-fd dup listen-on-socket
- dup add-completion
- f <win32-socket>
- ] with-destructors ;
-
-M: winnt (datagram) ( addrspec -- handle )
- [
- SOCK_DGRAM server-fd
- dup add-completion
- f <win32-socket>
+ <AcceptEx-args>
+ {
+ [ call-AcceptEx ]
+ [ wait-for-socket drop ]
+ [ sAcceptSocket*>> opened-socket ]
+ [ port>> pending-error ]
+ } cleave
+ ] curry with-timeout
] with-destructors ;
TUPLE: WSARecvFrom-args port
@@ -152,53 +100,38 @@ TUPLE: WSARecvFrom-args port
lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ;
: make-receive-buffer ( -- WSABUF )
- "WSABUF" malloc-object dup free-always
+ "WSABUF" malloc-object &free
default-buffer-size get over set-WSABUF-len
- default-buffer-size get malloc dup free-always over set-WSABUF-buf ;
+ default-buffer-size get malloc &free over set-WSABUF-buf ;
-: init-WSARecvFrom ( datagram WSARecvFrom -- )
- [ set-WSARecvFrom-args-port ] 2keep
- [
- >r handle>> handle>> r>
- set-WSARecvFrom-args-s*
- ] 2keep [
- >r datagram-port-addr sockaddr-type heap-size r>
- 2dup >r malloc dup free-always r> set-WSARecvFrom-args-lpFrom*
- >r malloc-int dup free-always r> set-WSARecvFrom-args-lpFromLen*
- ] keep
- make-receive-buffer over set-WSARecvFrom-args-lpBuffers*
- 1 over set-WSARecvFrom-args-dwBufferCount*
- 0 malloc-int dup free-always over set-WSARecvFrom-args-lpFlags*
- 0 malloc-int dup free-always over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
- (make-overlapped) swap set-WSARecvFrom-args-lpOverlapped* ;
-
-: WSARecvFrom-continuation ( WSARecvFrom -- n )
- dup WSARecvFrom-args-lpOverlapped*
- swap WSARecvFrom-args-port [ save-callback ] 2keep
- get-overlapped-result ;
+: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
+ WSARecvFrom-args new
+ swap >>port
+ dup port>> handle>> handle>> >>s*
+ dup port>> addr>> sockaddr-type heap-size
+ [ malloc &free >>lpFrom* ]
+ [ malloc-int &free >>lpFromLen* ] bi
+ make-receive-buffer >>lpBuffers*
+ 1 >>dwBufferCount*
+ 0 malloc-int &free >>lpFlags*
+ 0 malloc-int &free >>lpNumberOfBytesRecvd*
+ (make-overlapped) >>lpOverlapped* ;
: call-WSARecvFrom ( WSARecvFrom -- )
- \ WSARecvFrom-args >tuple*<
- WSARecvFrom
- socket-error* ;
+ WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
-: parse-WSARecvFrom ( n WSARecvFrom -- packet addrspec )
- [
- WSARecvFrom-args-lpBuffers* WSABUF-buf
- swap memory>byte-array
- ] keep
- [ WSARecvFrom-args-lpFrom* ] keep
- WSARecvFrom-args-port datagram-port-addr parse-sockaddr ;
+: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
+ [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ;
-M: winnt receive ( datagram -- packet addrspec )
+M: winnt (receive) ( datagram -- packet addrspec )
[
- check-datagram-port
- \ WSARecvFrom-args new
- [ init-WSARecvFrom ] keep
- [ call-WSARecvFrom ] keep
- [ WSARecvFrom-continuation ] keep
- [ WSARecvFrom-args-port pending-error ] keep
- parse-WSARecvFrom
+ <WSARecvFrom-args>
+ {
+ [ call-WSARecvFrom ]
+ [ wait-for-socket ]
+ [ port>> pending-error ]
+ [ parse-WSARecvFrom ]
+ } cleave
] with-destructors ;
TUPLE: WSASendTo-args port
@@ -206,49 +139,33 @@ TUPLE: WSASendTo-args port
dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ;
: make-send-buffer ( packet -- WSABUF )
- "WSABUF" malloc-object dup free-always
- over malloc-byte-array dup free-always over set-WSABUF-buf
- swap length over set-WSABUF-len ;
+ "WSABUF" malloc-object &free
+ [ >r malloc-byte-array &free r> set-WSABUF-buf ]
+ [ >r length r> set-WSABUF-len ]
+ [ nip ]
+ 2tri ;
-: init-WSASendTo ( packet addrspec datagram WSASendTo -- )
- [ set-WSASendTo-args-port ] 2keep
- [
- >r port-handle win32-file-handle r> set-WSASendTo-args-s*
- ] keep
- [
- >r make-sockaddr/size >r
- malloc-byte-array dup free-always
- r> r>
- [ set-WSASendTo-args-iToLen* ] keep
- set-WSASendTo-args-lpTo*
- ] keep
- [
- >r make-send-buffer r> set-WSASendTo-args-lpBuffers*
- ] keep
- 1 over set-WSASendTo-args-dwBufferCount*
- 0 over set-WSASendTo-args-dwFlags*
- 0 <uint> over set-WSASendTo-args-lpNumberOfBytesSent*
- (make-overlapped) swap set-WSASendTo-args-lpOverlapped* ;
-
-: WSASendTo-continuation ( WSASendTo -- )
- dup WSASendTo-args-lpOverlapped*
- swap WSASendTo-args-port
- [ save-callback ] 2keep
- get-overlapped-result drop ;
+: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
+ WSASendTo-args new
+ swap >>port
+ dup port>> handle>> handle>> >>s*
+ swap make-sockaddr/size
+ >r malloc-byte-array &free
+ r> [ >>lpTo* ] [ >>iToLen* ] bi*
+ swap make-send-buffer >>lpBuffers*
+ 1 >>dwBufferCount*
+ 0 >>dwFlags*
+ 0 <uint> >>lpNumberOfBytesSent*
+ (make-overlapped) >>lpOverlapped* ;
: call-WSASendTo ( WSASendTo -- )
- \ WSASendTo-args >tuple*<
- WSASendTo socket-error* ;
+ WSASendTo-args >tuple*< WSASendTo socket-error* ;
-USE: io.sockets
-
-M: winnt send ( packet addrspec datagram -- )
+M: winnt (send) ( packet addrspec datagram -- )
[
- check-datagram-send
- \ WSASendTo-args new
- [ init-WSASendTo ] keep
- [ call-WSASendTo ] keep
- [ WSASendTo-continuation ] keep
- WSASendTo-args-port pending-error
+ <WSASendTo-args>
+ [ call-WSASendTo ]
+ [ wait-for-socket drop ]
+ [ port>> pending-error ]
+ tri
] with-destructors ;
-
diff --git a/extra/io/windows/privileges/privileges.factor b/extra/io/windows/privileges/privileges.factor
new file mode 100755
index 0000000000..144c799912
--- /dev/null
+++ b/extra/io/windows/privileges/privileges.factor
@@ -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
diff --git a/extra/io/windows/sockets/sockets.factor b/extra/io/windows/sockets/sockets.factor
new file mode 100755
index 0000000000..67d827aa95
--- /dev/null
+++ b/extra/io/windows/sockets/sockets.factor
@@ -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 ;
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 4f34153b31..6b6b54ab92 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -8,18 +8,33 @@ windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields system accessors ;
IN: io.windows
-M: windows destruct-socket closesocket drop ;
+TUPLE: win32-handle handle disposed ;
-TUPLE: win32-file handle ptr ;
+: new-win32-handle ( handle class -- win32-handle )
+ new swap >>handle ;
-C: <win32-file> win32-file
+: <win32-handle> ( handle -- win32-handle )
+ win32-handle new-win32-handle ;
+
+M: win32-handle dispose* ( handle -- )
+ handle>> CloseHandle drop ;
+
+TUPLE: win32-file < win32-handle ptr ;
+
+: <win32-file> ( handle -- win32-file )
+ win32-file new-win32-handle ;
+
+M: win32-file init-handle ( handle -- )
+ drop ;
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
-M: windows normalize-directory ( string -- string )
- normalize-path "\\" ?tail drop "\\*" append ;
+: opened-file ( handle -- win32-file )
+ dup invalid-handle?
+ <win32-file> |dispose
+ dup add-completion ;
: share-mode ( -- fixnum )
{
@@ -36,176 +51,3 @@ M: windows normalize-directory ( string -- string )
: security-attributes-inherit ( -- obj )
default-security-attributes
TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable
-
-M: win32-file init-handle ( handle -- )
- drop ;
-
-M: win32-file close-handle ( handle -- )
- win32-file-handle close-handle ;
-
-M: alien close-handle ( handle -- )
- CloseHandle drop ;
-
-! Clean up resources (open handle) if add-completion fails
-: open-file ( path access-mode create-mode flags -- handle )
- [
- >r >r share-mode security-attributes-inherit r> r>
- CreateFile-flags f CreateFile
- dup invalid-handle? dup close-later
- dup add-completion
- ] with-destructors ;
-
-: open-pipe-r/w ( path -- handle )
- { GENERIC_READ GENERIC_WRITE } flags
- OPEN_EXISTING 0 open-file ;
-
-: open-read ( path -- handle length )
- GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
-
-: open-write ( path -- handle length )
- GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 ;
-
-: (open-append) ( path -- handle )
- GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
-
-: open-existing ( path -- handle )
- { GENERIC_READ GENERIC_WRITE } flags
- share-mode
- f
- OPEN_EXISTING
- FILE_FLAG_BACKUP_SEMANTICS
- f CreateFileW dup win32-error=0/f ;
-
-: maybe-create-file ( path -- handle ? )
- #! return true if file was just created
- { GENERIC_READ GENERIC_WRITE } flags
- share-mode
- f
- OPEN_ALWAYS
- 0 CreateFile-flags
- f CreateFileW dup win32-error=0/f
- GetLastError ERROR_ALREADY_EXISTS = not ;
-
-: set-file-pointer ( handle length method -- )
- >r dupd d>w/w <uint> r> SetFilePointer
- INVALID_SET_FILE_POINTER = [
- CloseHandle "SetFilePointer failed" throw
- ] when drop ;
-
-HOOK: open-append os ( path -- handle length )
-
-TUPLE: FileArgs
- hFile lpBuffer nNumberOfBytesToRead
- lpNumberOfBytesRet lpOverlapped ;
-
-C: <FileArgs> FileArgs
-
-: make-FileArgs ( port -- <FileArgs> )
- [ port-handle win32-file-handle ] keep
- [ buffer>> ] keep
- [
- buffer>> buffer-length
- "DWORD" <c-object>
- ] keep FileArgs-overlapped <FileArgs> ;
-
-: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
- [ FileArgs-hFile ] keep
- [ FileArgs-lpBuffer buffer-end ] keep
- [ FileArgs-lpBuffer buffer-capacity ] keep
- [ FileArgs-lpNumberOfBytesRet ] keep
- FileArgs-lpOverlapped ;
-
-: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
- [ FileArgs-hFile ] keep
- [ FileArgs-lpBuffer buffer@ ] keep
- [ FileArgs-lpBuffer buffer-length ] keep
- [ FileArgs-lpNumberOfBytesRet ] keep
- FileArgs-lpOverlapped ;
-
-M: windows (file-reader) ( path -- stream )
- open-read <win32-file> <input-port> ;
-
-M: windows (file-writer) ( path -- stream )
- open-write <win32-file> <output-port> ;
-
-M: windows (file-appender) ( path -- stream )
- open-append <win32-file> <output-port> ;
-
-M: windows move-file ( from to -- )
- [ normalize-path ] bi@ MoveFile win32-error=0/f ;
-
-M: windows delete-file ( path -- )
- normalize-path DeleteFile win32-error=0/f ;
-
-M: windows copy-file ( from to -- )
- dup parent-directory make-directories
- [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
-
-M: windows make-directory ( path -- )
- normalize-path
- f CreateDirectory win32-error=0/f ;
-
-M: windows delete-directory ( path -- )
- normalize-path
- RemoveDirectory win32-error=0/f ;
-
-HOOK: WSASocket-flags io-backend ( -- DWORD )
-
-TUPLE: win32-socket < win32-file overlapped ;
-
-: <win32-socket> ( handle overlapped -- win32-socket )
- win32-socket new
- swap >>overlapped
- swap >>handle ;
-
-: open-socket ( family type -- socket )
- 0 f 0 WSASocket-flags WSASocket dup socket-error ;
-
-USE: windows.winsock
-: init-sockaddr ( port# addrspec -- sockaddr )
- dup sockaddr-type <c-object>
- [ swap protocol-family swap set-sockaddr-in-family ] keep
- [ >r htons r> set-sockaddr-in-port ] keep ;
-
-: server-sockaddr ( port# addrspec -- sockaddr )
- init-sockaddr
- [ INADDR_ANY swap set-sockaddr-in-addr ] keep ;
-
-: bind-socket ( socket sockaddr addrspec -- )
- [ server-sockaddr ] keep
- sockaddr-type heap-size bind socket-error ;
-
-TUPLE: socket-destructor alien ;
-
-C: <socket-destructor> socket-destructor
-
-HOOK: destruct-socket io-backend ( obj -- )
-
-M: socket-destructor dispose ( obj -- )
- alien>> destruct-socket ;
-
-: close-socket-later ( handle -- )
- <socket-destructor> <only-once> |dispose drop ;
-
-: server-fd ( addrspec type -- fd )
- >r dup protocol-family r> open-socket
- dup close-socket-later
- dup rot make-sockaddr/size bind socket-error ;
-
-USE: namespaces
-
-! http://support.microsoft.com/kb/127144
-! NOTE: Possibly tweak this because of SYN flood attacks
-: listen-backlog ( -- n ) HEX: 7fffffff ; inline
-
-: listen-on-socket ( socket -- )
- listen-backlog listen winsock-return-check ;
-
-M: win32-socket dispose ( stream -- )
- win32-file-handle closesocket drop ;
-
-M: windows addrinfo-error ( n -- )
- winsock-return-check ;
-
-: tcp-socket ( addrspec -- socket )
- protocol-family SOCK_STREAM open-socket ;
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
index 5330a815a3..42ccac2312 100755
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -122,6 +122,13 @@ FUNCTION: int SSL_shutdown ( 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: X509* SSL_get_peer_certificate ( SSL* s ) ;
diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor
old mode 100644
new mode 100755
index 39d11b562b..0699afc682
--- a/extra/windows/winsock/winsock.factor
+++ b/extra/windows/winsock/winsock.factor
@@ -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