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> > 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: { $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 [ ] [ heap-size ] bi ; +: empty-sockaddr/size ( addrspec -- sockaddr size ) + sockaddr-type [ ] [ 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/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 [ 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 ] bi* accept ; inline M: object (accept) ( server addrspec -- fd ) 2dup do-accept @@ -100,7 +100,7 @@ packet-size receive-buffer set-global packet-size ! nbytes 0 ! flags sockaddr ! from - len ! fromlen + len ! 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 30b69bf40e..ef3db0dcd1 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -1,19 +1,17 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types io.backend io.files io.windows kernel math +USING: alien.c-types io.binary io.backend io.files io.buffers +io.windows kernel math splitting windows windows.kernel32 windows.time calendar combinators math.functions sequences namespaces words symbols system -combinators.lib io.ports destructors math.bitfields.lib ; +combinators.lib io.ports destructors accessors +math.bitfields math.bitfields.lib ; IN: io.windows.files : open-file ( path access-mode create-mode flags -- handle ) [ >r >r share-mode security-attributes-inherit r> r> - CreateFile-flags f CreateFile - dup invalid-handle? - - |dispose - dup add-completion + CreateFile-flags f CreateFile opened-file ] with-destructors ; : open-pipe-r/w ( path -- win32-file ) @@ -213,7 +211,7 @@ M: winnt link-info ( path -- info ) : file-times ( path -- timestamp timestamp timestamp ) [ - normalize-path open-existing &close-handle + normalize-path open-existing &dispose handle>> "FILETIME" "FILETIME" "FILETIME" @@ -229,7 +227,7 @@ M: winnt link-info ( path -- info ) #! timestamp order: creation access write [ >r >r >r - normalize-path open-existing &close-handle + normalize-path open-existing &dispose handle>> r> r> r> (set-file-times) ] with-destructors ; @@ -246,5 +244,5 @@ M: winnt touch-file ( path -- ) [ normalize-path maybe-create-file >r &dispose r> - [ drop ] [ f now dup (set-file-times) ] if + [ drop ] [ handle>> f now dup (set-file-times) ] if ] with-destructors ; 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 6116b635c2..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 diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index 1e9cb4738c..72dfca9df3 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -1,86 +1,44 @@ -USING: alien alien.c-types alien.syntax arrays continuations -destructors generic io.mmap io.ports io.windows -kernel libc math namespaces quotations sequences windows -windows.advapi32 windows.kernel32 io.backend system ; +USING: alien alien.c-types arrays destructors generic io.mmap +io.ports io.windows io.windows.files io.windows.privileges +kernel libc math math.bitfields namespaces quotations sequences +windows windows.advapi32 windows.kernel32 io.backend system +accessors locals ; IN: io.windows.mmap -TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES +: create-file-mapping + CreateFileMapping [ win32-error=0/f ] keep ; -! Security tokens -! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ +: map-view-of-file + MapViewOfFile [ win32-error=0/f ] keep ; -: (open-process-token) ( handle -- handle ) - { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" - [ 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" - [ LookupPrivilegeValue win32-error=0/f ] keep ; +C: win32-mapped-file -: make-token-privileges ( name ? -- obj ) - "TOKEN_PRIVILEGES" - 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep - "LUID_AND_ATTRIBUTES" malloc-array &free - over set-TOKEN_PRIVILEGES-Privileges - - swap [ - SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges - set-LUID_AND_ATTRIBUTES-Attributes - ] when - - >r lookup-privilege r> - [ - TOKEN_PRIVILEGES-Privileges - >r 0 r> LUID_AND_ATTRIBUTES-nth - set-LUID_AND_ATTRIBUTES-Luid - ] keep ; - -: set-privilege ( name ? -- ) - [ - -rot 0 -rot make-token-privileges - dup length f f AdjustTokenPrivileges win32-error=0/f - ] with-process-token ; - -HOOK: with-privileges io-backend ( seq quot -- ) inline - -M: winnt with-privileges - over [ [ t set-privilege ] each ] curry compose - swap [ [ f set-privilege ] each ] curry [ ] cleanup ; - -M: wince with-privileges - nip call ; - -: mmap-open ( path access-mode create-mode flProtect access -- handle handle address ) - { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ - >r >r 0 open-file dup f r> 0 0 f - CreateFileMapping [ win32-error=0/f ] keep |close-handle - dup - r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep |close-handle - ] with-privileges ; - M: windows (mapped-file) [ - swap - GENERIC_WRITE GENERIC_READ bitor + { GENERIC_WRITE GENERIC_READ } flags OPEN_ALWAYS - PAGE_READWRITE SEC_COMMIT bitor + { PAGE_READWRITE SEC_COMMIT } flags FILE_MAP_ALL_ACCESS mmap-open - -rot 2array + -rot ] with-destructors ; M: windows close-mapped-file ( mapped-file -- ) [ - [ handle>> [ &close-handle drop ] each ] - [ address>> UnmapViewOfFile win32-error=0/f ] - bi + [ handle>> &dispose drop ] + [ address>> UnmapViewOfFile win32-error=0/f ] bi ] with-destructors ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 42e43d5f42..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 @@ -28,8 +29,8 @@ SYMBOL: master-completion-port : ( -- handle ) INVALID_HANDLE_VALUE f ; -M: winnt add-completion ( handle -- ) - master-completion-port get-global drop ; +M: winnt add-completion ( win32-handle -- ) + handle>> master-completion-port get-global drop ; : eof? ( error -- ? ) dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ; @@ -64,7 +65,6 @@ M: winnt add-completion ( handle -- ) :: wait-for-overlapped ( ms -- overlapped ? ) master-completion-port get-global - r> INFINITE or ! timeout 0 ! bytes f ! key f ! overlapped @@ -82,9 +82,9 @@ M: winnt add-completion ( handle -- ) GetLastError dup expected-io-error? [ 2drop f ] [ >r lookup-callback [ thread>> ] [ port>> ] bi r> dup eof? - [ drop t >>eof drop ] - [ (win32-error-string) >>error drop ] if - thread>> resume t + [ drop t >>eof ] + [ (win32-error-string) >>error ] if drop + resume t ] if ] [ lookup-callback @@ -102,6 +102,9 @@ M: winnt init-io ( -- ) H{ } clone io-hash set-global windows.winsock:init-winsock ; +: update-file-ptr ( n port -- ) + handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; + : finish-flush ( n port -- ) [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; @@ -124,7 +127,7 @@ M: winnt (wait-to-write) over zero? [ t >>eof 2drop ] [ - [ buffer>> n>buffer ] [ update-file-ptr ] bi + [ buffer>> n>buffer ] [ update-file-ptr ] 2bi ] if ; : ((wait-to-read)) ( port -- ) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index e99aa18196..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 ; @@ -55,7 +56,4 @@ M: winnt FileArgs-overlapped ( port -- overlapped ) M: winnt open-append [ dup file-info size>> ] [ drop 0 ] recover - >r (open-append) r> ; - -: update-file-ptr ( n port -- ) - handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; + >r (open-append) r> >>ptr ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index bad70501d7..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' ) @@ -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? &dispose ; + CreateFile dup invalid-handle? &dispose handle>> ; -: redirect-append ( default path access-mode create-mode -- handle ) +: redirect-append ( path access-mode create-mode -- handle ) >r >r path>> r> r> drop OPEN_ALWAYS redirect-file @@ -60,14 +61,13 @@ IN: io.windows.nt.launcher : set-inherit ( handle ? -- ) >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; -: redirect-handle ( default handle access-mode create-mode -- handle ) - 2drop nip - handle>> duplicate-handle dup t set-inherit ; +: redirect-handle ( handle access-mode create-mode -- handle ) + 2drop handle>> duplicate-handle dup t set-inherit ; -: redirect-stream ( default stream access-mode create-mode -- handle ) - >r >r underlying-handle r> r> redirect-handle ; +: redirect-stream ( stream access-mode create-mode -- handle ) + >r >r underlying-handle handle>> r> r> redirect-handle ; -: redirect ( default obj access-mode create-mode -- handle ) +: redirect ( obj access-mode create-mode -- handle ) { { [ pick not ] [ redirect-default ] } { [ pick +closed+ eq? ] [ redirect-closed ] } @@ -78,21 +78,20 @@ IN: io.windows.nt.launcher } cond ; : redirect-stdout ( process args -- handle ) + drop stdout>> GENERIC_WRITE CREATE_ALWAYS redirect - STD_OUTPUT_HANDLE GetStdHandle ; + STD_OUTPUT_HANDLE GetStdHandle or ; : redirect-stderr ( process args -- handle ) over stderr>> +stdout+ eq? [ - lpStartupInfo>> - STARTUPINFO-hStdOutput nip + lpStartupInfo>> STARTUPINFO-hStdOutput ] [ drop - f - swap stderr>> + stderr>> GENERIC_WRITE CREATE_ALWAYS redirect @@ -100,11 +99,12 @@ IN: io.windows.nt.launcher ] if ; : redirect-stdin ( process args -- handle ) + drop stdin>> GENERIC_READ OPEN_EXISTING redirect - STD_INPUT_HANDLE GetStdHandle ; + STD_INPUT_HANDLE GetStdHandle or ; M: winnt fill-redirection ( process args -- ) [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 2257c48f99..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? - - |close-handle - dup add-completion ; + CreateFile opened-file ; TUPLE: win32-monitor-port < input-port recursive ; @@ -93,7 +89,7 @@ TUPLE: win32-monitor < monitor port ; : fill-queue-thread ( monitor -- ) [ dup fill-queue (fill-queue-thread) ] - [ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ; + [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ; M:: winnt (monitor) ( path recursive? mailbox -- monitor ) [ 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 4a0b8119ba..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 - |dispose - dup add-completion ; + CreateNamedPipe opened-file ; : open-other-end ( name -- handle ) GENERIC_WRITE @@ -29,10 +26,7 @@ IN: io.windows.nt.pipes OPEN_EXISTING FILE_FLAG_OVERLAPPED f - CreateFile - dup win32-error=0/f - |dispose - dup add-completion ; + CreateFile opened-file ; : unique-pipe-name ( -- string ) [ 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" + [ 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" + [ LookupPrivilegeValue win32-error=0/f ] keep ; + +: make-token-privileges ( name ? -- obj ) + "TOKEN_PRIVILEGES" + 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 0a3dca279e..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 ) @@ -11,9 +12,6 @@ IN: io.windows.nt.sockets M: winnt WSASocket-flags ( -- DWORD ) WSA_FLAG_OVERLAPPED ; -: wait-for-socket ( args -- n ) - [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ; - : get-ConnectEx-ptr ( socket -- void* ) SIO_GET_EXTENSION_FUNCTION_POINTER WSAID_CONNECTEX @@ -33,7 +31,10 @@ TUPLE: ConnectEx-args port s* name* namelen* lpSendBuffer* dwSendDataLength* lpdwBytesSent* lpOverlapped* ptr* ; -: ( sockaddr size -- ) +: wait-for-socket ( args -- n ) + [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ; + +: ( sockaddr size -- ConnectEx ) ConnectEx-args new swap >>namelen* swap >>name* @@ -61,18 +62,18 @@ TUPLE: AcceptEx-args port sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength* dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ; -: init-accept-buffer ( server-port AcceptEx -- ) - swap addr>> sockaddr-type heap-size 16 + +: init-accept-buffer ( addr AcceptEx -- ) + swap sockaddr-type heap-size 16 + [ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer* drop ; -: ( server-port -- AcceptEx ) +: ( server addr -- AcceptEx ) AcceptEx-args new 2dup init-accept-buffer + swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket* + over handle>> handle>> >>sListenSocket* swap >>port - dup port>> handle>> handle>> >>sListenSocket* - dup port>> addr>> tcp-socket >>sAcceptSocket* 0 >>dwReceiveDataLength* f >>lpdwBytesReceived* (make-overlapped) >>lpOverlapped* ; @@ -81,20 +82,17 @@ TUPLE: AcceptEx-args port AcceptEx-args >tuple*< AcceptEx drop winsock-error-string [ throw ] when* ; -: finish-accept ( AcceptEx -- client ) - sAcceptSocket*>> [ |dispose ] [ add-completion ] bi ; - -M: winnt (accept) ( server -- handle ) +M: object (accept) ( server addr -- handle ) [ [ { [ call-AcceptEx ] [ wait-for-socket drop ] - [ finish-accept ] + [ sAcceptSocket*>> opened-socket ] [ port>> pending-error ] } cleave - ] with-timeout + ] curry with-timeout ] with-destructors ; TUPLE: WSARecvFrom-args port @@ -107,7 +105,7 @@ TUPLE: WSARecvFrom-args port default-buffer-size get malloc &free over set-WSABUF-buf ; : ( datagram -- WSARecvFrom ) - WSARecvFrom new + WSARecvFrom-args new swap >>port dup port>> handle>> handle>> >>s* dup port>> addr>> sockaddr-type heap-size @@ -125,7 +123,7 @@ TUPLE: WSARecvFrom-args port : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ; -M: winnt receive ( datagram -- packet addrspec ) +M: winnt (receive) ( datagram -- packet addrspec ) [ { @@ -163,7 +161,7 @@ TUPLE: WSASendTo-args port : call-WSASendTo ( WSASendTo -- ) WSASendTo-args >tuple*< WSASendTo socket-error* ; -M: winnt send ( packet addrspec datagram -- ) +M: winnt (send) ( packet addrspec datagram -- ) [ [ call-WSASendTo ] 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 index 52902a88e9..67d827aa95 100755 --- a/extra/io/windows/sockets/sockets.factor +++ b/extra/io/windows/sockets/sockets.factor @@ -1,5 +1,5 @@ -USING: kernel accessors io.sockets io.windows -windows.winsock system ; +USING: kernel accessors io.sockets io.windows io.backend +windows.winsock system destructors alien.c-types ; IN: io.windows.sockets HOOK: WSASocket-flags io-backend ( -- DWORD ) @@ -17,24 +17,29 @@ M: win32-socket dispose ( stream -- ) [ empty-sockaddr/size ] [ protocol-family ] bi pick set-sockaddr-in-family ; -: open-socket ( addrspec type -- win3-socket ) +: opened-socket ( handle -- win32-socket ) + |dispose dup add-completion ; + +: open-socket ( addrspec type -- win32-socket ) >r protocol-family r> 0 f 0 WSASocket-flags WSASocket dup socket-error - |dispose - dup add-completion ; + opened-socket ; -M: object get-local-address ( socket addrspec -- sockaddr ) - >r handle>> r> empty-sockaddr/size +M: object (get-local-address) ( socket addrspec -- sockaddr ) + >r handle>> r> empty-sockaddr/size [ getsockname socket-error ] 2keep drop ; +: bind-socket ( win32-socket sockaddr len -- ) + >r >r handle>> r> r> bind socket-error ; + M: object ((client)) ( addrspec -- handle ) - [ open-socket ] [ drop ] 2bi - [ unspecific-sockaddr/size bind socket-error ] [ drop ] 2bi ; + [ SOCK_STREAM open-socket ] keep + [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ; : server-socket ( addrspec type -- fd ) [ open-socket ] [ drop ] 2bi - [ make-sockaddr/size bind socket-error ] [ drop ] 2bi ; + [ make-sockaddr/size bind-socket ] [ drop ] 2bi ; ! http://support.microsoft.com/kb/127144 ! NOTE: Possibly tweak this because of SYN flood attacks diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 05c55ab5fe..6b6b54ab92 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -19,7 +19,7 @@ TUPLE: win32-handle handle disposed ; M: win32-handle dispose* ( handle -- ) handle>> CloseHandle drop ; -TUPLE: win32-file handle ptr disposed ; +TUPLE: win32-file < win32-handle ptr ; : ( handle -- win32-file ) win32-file new-win32-handle ; @@ -31,6 +31,11 @@ HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) +: opened-file ( handle -- win32-file ) + dup invalid-handle? + |dispose + dup add-completion ; + : share-mode ( -- fixnum ) { FILE_SHARE_READ 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