parent
4192413861
commit
ceba5efb1f
extra
io
sniffer/bsd
windows
|
@ -1,25 +1,31 @@
|
|||
USING: help.markup help.syntax kernel destructors ;
|
||||
USING: help.markup help.syntax libc kernel destructors ;
|
||||
IN: destructors
|
||||
|
||||
HELP: add-destructor
|
||||
{ $values { "obj" "an object" }
|
||||
{ "quot" "a quotation" }
|
||||
{ "always?" "always cleanup?" }
|
||||
} { $description "Adds a destructor to be invoked by the " { $link call-destructors } " word to the current dynamic scope. Setting the 'always cleanup?' flag to f allows for keeping resources, such as a successfully opened file descriptor, open after a call to " { $link with-destructors } "." }
|
||||
{ $notes "The use of the " { $link with-destructors } " word is preferred over calling " { $link call-destructors } " manually." $nl
|
||||
"Destructors are not allowed to throw exceptions. No exceptions." }
|
||||
{ $see-also call-destructors with-destructors } ;
|
||||
HELP: free-always
|
||||
{ $values { "alien" "alien returned by malloc" } }
|
||||
{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " ends." }
|
||||
{ $see-also free-later } ;
|
||||
|
||||
HELP: call-destructors
|
||||
{ $description "Iterates through a sequence of destructor tuples, calling the destructor quotation on each one." }
|
||||
{ $notes "The use of the " { $link with-destructors } " word is preferred over calling " { $link call-destructors } " manually." }
|
||||
{ $see-also add-destructor with-destructors } ;
|
||||
HELP: free-later
|
||||
{ $values { "alien" "alien returned by malloc" } }
|
||||
{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " errors or else the object will persist and manual cleanup is required later." }
|
||||
{ $see-also free-always } ;
|
||||
|
||||
HELP: close-always
|
||||
{ $values { "handle" "an OS-dependent handle" } }
|
||||
{ $description "Adds a destructor that will close the system resource upon reaching the end of the quotation passed to " { $link with-destructors } "." }
|
||||
{ $see-also close-later } ;
|
||||
|
||||
HELP: close-later
|
||||
{ $values { "handle" "an OS-dependent handle" } }
|
||||
{ $description "Adds a destructor that will close the system resource if an error occurs in the quotation passed to " { $link with-destructors } ". Otherwise, manual cleanup of the resource is required later." }
|
||||
{ $see-also close-always } ;
|
||||
|
||||
HELP: with-destructors
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by calling " { $link add-destructor } ". After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
|
||||
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link (destruct) } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
|
||||
{ $notes "Destructors are not allowed to throw exceptions. No exceptions." }
|
||||
{ $examples
|
||||
{ $code "[ 10 malloc dup [ free \"free 10 bytes\" print ] t add-destructor drop ] with-destructors" }
|
||||
{ $code "[ 10 malloc free-always ] with-destructors" }
|
||||
}
|
||||
{ $see-also add-destructor call-destructors } ;
|
||||
{ $see-also } ;
|
||||
|
|
|
@ -3,27 +3,39 @@ IN: temporary
|
|||
|
||||
TUPLE: dummy-obj destroyed? ;
|
||||
|
||||
TUPLE: dummy-destructor ;
|
||||
|
||||
: <dummy-destructor> ( obj ? -- newobj )
|
||||
<destructor> dummy-destructor construct-delegate ;
|
||||
|
||||
M: dummy-destructor (destruct) ( obj -- )
|
||||
destructor-obj t swap set-dummy-obj-destroyed? ;
|
||||
|
||||
: <dummy-obj>
|
||||
\ dummy-obj construct-empty ;
|
||||
|
||||
: destroy-always
|
||||
t <dummy-destructor> push-destructor ;
|
||||
|
||||
: destroy-later
|
||||
f <dummy-destructor> push-destructor ;
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
<dummy-obj>
|
||||
dup [ t swap set-dummy-obj-destroyed? ] t add-destructor
|
||||
<dummy-obj> dup destroy-always
|
||||
] with-destructors dummy-obj-destroyed?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
<dummy-obj>
|
||||
dup [ t swap set-dummy-obj-destroyed? ] f add-destructor
|
||||
<dummy-obj> dup destroy-later
|
||||
] with-destructors dummy-obj-destroyed?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
<dummy-obj> [
|
||||
[
|
||||
dup [ t swap set-dummy-obj-destroyed? ] t add-destructor
|
||||
dup destroy-always
|
||||
"foo" throw
|
||||
] with-destructors
|
||||
] catch drop dummy-obj-destroyed?
|
||||
|
@ -32,7 +44,7 @@ TUPLE: dummy-obj destroyed? ;
|
|||
[ t ] [
|
||||
<dummy-obj> [
|
||||
[
|
||||
dup [ t swap set-dummy-obj-destroyed? ] f add-destructor
|
||||
dup destroy-later
|
||||
"foo" throw
|
||||
] with-destructors
|
||||
] catch drop dummy-obj-destroyed?
|
||||
|
|
|
@ -1,38 +1,94 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations kernel namespaces sequences vectors ;
|
||||
USING: continuations io.backend libc kernel namespaces
|
||||
sequences system vectors ;
|
||||
IN: destructors
|
||||
|
||||
SYMBOL: destructors
|
||||
SYMBOL: errored?
|
||||
TUPLE: destructor obj quot always? ;
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: destructor obj always? destroyed? ;
|
||||
|
||||
: filter-destructors ( -- )
|
||||
errored? get [
|
||||
destructors [ [ destructor-always? ] subset ] change
|
||||
] unless ;
|
||||
: <destructor> ( obj always? -- newobj )
|
||||
{
|
||||
set-destructor-obj
|
||||
set-destructor-always?
|
||||
} destructor construct ;
|
||||
|
||||
PRIVATE>
|
||||
: push-destructor ( obj -- )
|
||||
destructors [ ?push ] change ;
|
||||
|
||||
: add-destructor ( obj quot always? -- )
|
||||
\ destructor construct-boa destructors [ ?push ] change ;
|
||||
GENERIC: (destruct) ( obj -- )
|
||||
|
||||
: call-destructors ( -- )
|
||||
destructors get [
|
||||
dup destructor-obj swap destructor-quot call
|
||||
] each ;
|
||||
: destruct ( obj -- )
|
||||
dup destructor-destroyed? [
|
||||
drop
|
||||
] [
|
||||
[ (destruct) t ] keep set-destructor-destroyed?
|
||||
] if ;
|
||||
|
||||
: destruct-always ( destructor -- )
|
||||
dup destructor-always? [
|
||||
destruct
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: with-destructors ( quot -- )
|
||||
[
|
||||
[ call ] [ errored? on ] recover
|
||||
filter-destructors call-destructors
|
||||
errored? get [ rethrow ] when
|
||||
[ call ]
|
||||
[ destructors get [ destruct-always ] each ]
|
||||
[ destructors get [ destruct ] each ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
|
||||
|
||||
TUPLE: memory-destructor ;
|
||||
|
||||
: <memory-destructor> ( obj ? -- newobj )
|
||||
<destructor> memory-destructor construct-delegate ;
|
||||
|
||||
TUPLE: handle-destructor ;
|
||||
|
||||
: <handle-destructor> ( obj ? -- newobj )
|
||||
<destructor> handle-destructor construct-delegate ;
|
||||
|
||||
TUPLE: socket-destructor ;
|
||||
|
||||
: <socket-destructor> ( obj ? -- newobj )
|
||||
<destructor> socket-destructor construct-delegate ;
|
||||
|
||||
M: memory-destructor (destruct) ( obj -- )
|
||||
destructor-obj free ;
|
||||
|
||||
HOOK: (handle-destructor) io-backend ( obj -- )
|
||||
HOOK: (socket-destructor) io-backend ( obj -- )
|
||||
|
||||
M: handle-destructor (destruct) ( obj -- ) (handle-destructor) ;
|
||||
M: socket-destructor (destruct) ( obj -- ) (socket-destructor) ;
|
||||
|
||||
: free-always ( alien -- )
|
||||
t <memory-destructor> push-destructor ;
|
||||
|
||||
: free-later ( alien -- )
|
||||
f <memory-destructor> push-destructor ;
|
||||
|
||||
: close-always ( handle -- )
|
||||
t <handle-destructor> push-destructor ;
|
||||
|
||||
: close-later ( handle -- )
|
||||
f <handle-destructor> push-destructor ;
|
||||
|
||||
: close-socket-always ( handle -- )
|
||||
t <socket-destructor> push-destructor ;
|
||||
|
||||
: close-socket-later ( handle -- )
|
||||
f <socket-destructor> push-destructor ;
|
||||
|
||||
USE-IF: windows? destructors.windows
|
||||
USE-IF: unix? destructors.unix
|
||||
|
||||
|
||||
|
||||
! : add-destructor ( word quot -- )
|
||||
! >quotation
|
||||
! "slot-destructor" set-word-prop ;
|
||||
|
|
|
@ -0,0 +1,9 @@
|
|||
USING: destructors io.windows kernel qualified ;
|
||||
QUALIFIED: unix
|
||||
IN: detructors.unix
|
||||
|
||||
M: unix-io (handle-destructor) ( obj -- )
|
||||
destructor-obj close drop ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
USING: destructors io.windows kernel windows.kernel32
|
||||
windows.winsock ;
|
||||
IN: detructors.windows
|
||||
|
||||
M: windows-io (handle-destructor) ( obj -- )
|
||||
destructor-obj CloseHandle drop ;
|
||||
|
||||
M: windows-io (socket-destructor) ( obj -- )
|
||||
destructor-obj closesocket drop ;
|
||||
|
||||
|
|
@ -50,7 +50,7 @@ C: <sniffer-spec> sniffer-spec
|
|||
: make-ifreq-props ( ifname -- ifreq )
|
||||
"ifreq" <c-object>
|
||||
12 <short> 16 0 pad-right over set-ifreq-props
|
||||
swap malloc-char-string dup [ free ] t add-destructor
|
||||
swap malloc-char-string dup free-always
|
||||
over set-ifreq-name ;
|
||||
|
||||
: make-ioctl-buffer ( fd -- buffer )
|
||||
|
@ -77,7 +77,7 @@ M: unix-io <sniffer> ( obj -- sniffer )
|
|||
[
|
||||
sniffer-spec-path
|
||||
open-read
|
||||
dup [ unix:close ] f add-destructor
|
||||
dup close-later
|
||||
] keep
|
||||
dupd sniffer-spec-ifname ioctl-sniffer-fd
|
||||
dup make-ioctl-buffer
|
||||
|
|
|
@ -1,7 +1,10 @@
|
|||
USING: alien alien.c-types destructors io.windows libc
|
||||
USING: alien alien.c-types arrays continuations
|
||||
destructors io.windows libc
|
||||
io.nonblocking io.streams.duplex windows.types math
|
||||
windows.kernel32 windows namespaces io.launcher kernel
|
||||
io.windows.nt.backend ;
|
||||
sequences io.windows.nt.backend windows.errors ;
|
||||
USE: io
|
||||
USE: prettyprint
|
||||
IN: io.windows.launcher
|
||||
|
||||
! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed."
|
||||
|
@ -88,35 +91,44 @@ C: <pipe> pipe
|
|||
|
||||
: ERROR_PIPE_CONNECT 535 ; inline
|
||||
|
||||
: pipe-connect-error? ( n -- ? )
|
||||
ERROR_SUCCESS ERROR_PIPE_CONNECT 2array member? not ;
|
||||
|
||||
! clear "ls" <process-stream> contents
|
||||
M: windows-nt-io <process-stream> ( command -- stream )
|
||||
[
|
||||
|
||||
break
|
||||
default-CreateProcess-args
|
||||
TRUE over set-CreateProcess-args-bInheritHandles
|
||||
|
||||
! over set-CreateProcess-args-stdin-pipe
|
||||
|
||||
dup CreateProcess-args-lpStartupInfo
|
||||
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
|
||||
|
||||
factor-pipe-name create-named-pipe
|
||||
global [ "Named pipe: " write dup . ] bind
|
||||
dup t set-inherit
|
||||
[ add-completion ] keep
|
||||
|
||||
! CreateFile
|
||||
! factor-pipe-name open-pipe-r/w
|
||||
factor-pipe-name GENERIC_READ GENERIC_WRITE bitor 0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f CreateFile dup invalid-handle? dup [ CloseHandle drop ] f add-destructor
|
||||
factor-pipe-name GENERIC_READ GENERIC_WRITE bitor
|
||||
0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f
|
||||
CreateFile
|
||||
global [ "Created File: " write dup . ] bind
|
||||
dup invalid-handle? dup close-later
|
||||
dup add-completion
|
||||
|
||||
swap (make-overlapped) ConnectNamedPipe zero? [
|
||||
GetLastError ERROR_PIPE_CONNECT = [
|
||||
GetLastError pipe-connect-error? [
|
||||
win32-error-string throw
|
||||
] unless
|
||||
] when
|
||||
] when
|
||||
|
||||
dup t set-inherit
|
||||
|
||||
! ERROR_PIPE_CONNECTED
|
||||
[ pick set-CreateProcess-args-stdin-pipe ] keep
|
||||
global [ "Setting the stdios to: " write dup . ] bind
|
||||
[ over set-STARTUPINFO-hStdOutput ] keep
|
||||
[ over set-STARTUPINFO-hStdInput ] keep
|
||||
swap set-STARTUPINFO-hStdError
|
||||
|
@ -134,7 +146,7 @@ M: windows-nt-io <process-stream> ( command -- stream )
|
|||
0
|
||||
CreatePipe win32-error=0/f
|
||||
] 2keep
|
||||
[ *void* dup [ CloseHandle ] f add-destructor ] 2apply <pipe> ;
|
||||
[ *void* dup close-later ] 2apply <pipe> ;
|
||||
|
||||
M: windows-ce-io <process-stream>
|
||||
[
|
||||
|
|
|
@ -31,7 +31,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
|||
"TOKEN_PRIVILEGES" <c-object>
|
||||
1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep
|
||||
"LUID_AND_ATTRIBUTES" malloc-array
|
||||
dup [ free ] t add-destructor over set-TOKEN_PRIVILEGES-Privileges
|
||||
dup free-always over set-TOKEN_PRIVILEGES-Privileges
|
||||
|
||||
swap [
|
||||
SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
|
||||
|
@ -60,10 +60,10 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
|||
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
|
||||
>r >r open-file dup f r> 0 0 f
|
||||
CreateFileMapping [ win32-error=0/f ] keep
|
||||
dup [ CloseHandle drop ] f add-destructor
|
||||
dup close-later
|
||||
dup
|
||||
r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep
|
||||
dup [ CloseHandle drop ] f add-destructor
|
||||
dup close-later
|
||||
] with-privileges ;
|
||||
|
||||
M: windows-io <mapped-file> ( path length -- mmap )
|
||||
|
@ -81,7 +81,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
|
|||
M: windows-io close-mapped-file ( mapped-file -- )
|
||||
[
|
||||
dup mapped-file-handle [
|
||||
[ CloseHandle drop ] t add-destructor
|
||||
close-always
|
||||
] each
|
||||
mapped-file-address UnmapViewOfFile win32-error=0/f
|
||||
] with-destructors ;
|
||||
|
|
|
@ -40,7 +40,7 @@ TUPLE: io-callback port continuation ;
|
|||
C: <io-callback> io-callback
|
||||
|
||||
: (make-overlapped) ( -- overlapped-ext )
|
||||
"OVERLAPPED" malloc-object dup [ free ] t add-destructor
|
||||
"OVERLAPPED" malloc-object dup free-always
|
||||
0 over set-OVERLAPPED-internal
|
||||
0 over set-OVERLAPPED-internal-high
|
||||
0 over set-OVERLAPPED-offset-high
|
||||
|
|
|
@ -81,7 +81,7 @@ TUPLE: AcceptEx-args port
|
|||
|
||||
: init-accept-buffer ( server-port AcceptEx -- )
|
||||
>r server-port-addr sockaddr-type heap-size 16 +
|
||||
dup dup 2 * malloc dup [ free ] t add-destructor r>
|
||||
dup dup 2 * malloc dup free-always r>
|
||||
[ set-AcceptEx-args-lpOutputBuffer* ] keep
|
||||
[ set-AcceptEx-args-dwLocalAddressLength* ] keep
|
||||
set-AcceptEx-args-dwRemoteAddressLength* ;
|
||||
|
@ -174,17 +174,17 @@ TUPLE: WSARecvFrom-args port
|
|||
set-WSARecvFrom-args-s*
|
||||
] 2keep [
|
||||
>r datagram-port-addr sockaddr-type heap-size r>
|
||||
2dup >r malloc dup [ free ] t add-destructor r> set-WSARecvFrom-args-lpFrom*
|
||||
>r malloc-int dup [ free ] t add-destructor r> set-WSARecvFrom-args-lpFromLen*
|
||||
2dup >r malloc dup free-always r> set-WSARecvFrom-args-lpFrom*
|
||||
>r malloc-int dup free-always r> set-WSARecvFrom-args-lpFromLen*
|
||||
] keep
|
||||
"WSABUF" malloc-object dup [ free ] t add-destructor
|
||||
"WSABUF" malloc-object dup free-always
|
||||
2dup swap set-WSARecvFrom-args-lpBuffers*
|
||||
default-buffer-size [ malloc dup [ free ] t add-destructor ] keep
|
||||
default-buffer-size [ malloc dup free-always ] keep
|
||||
pick set-WSABUF-len
|
||||
swap set-WSABUF-buf
|
||||
1 over set-WSARecvFrom-args-dwBufferCount*
|
||||
0 malloc-int dup [ free ] t add-destructor over set-WSARecvFrom-args-lpFlags*
|
||||
0 malloc-int dup [ free ] t add-destructor over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
|
||||
0 malloc-int dup free-always over set-WSARecvFrom-args-lpFlags*
|
||||
0 malloc-int dup free-always over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
|
||||
(make-overlapped) [ over set-WSARecvFrom-args-lpOverlapped* ] keep
|
||||
swap WSARecvFrom-args-port set-port-overlapped ;
|
||||
|
||||
|
@ -230,14 +230,14 @@ TUPLE: WSASendTo-args port
|
|||
set-WSASendTo-args-s*
|
||||
] keep [
|
||||
>r make-sockaddr >r
|
||||
malloc-byte-array dup [ free ] t add-destructor
|
||||
malloc-byte-array dup free-always
|
||||
r> heap-size r>
|
||||
[ set-WSASendTo-args-iToLen* ] keep
|
||||
set-WSASendTo-args-lpTo*
|
||||
] keep [
|
||||
"WSABUF" malloc-object dup [ free ] t add-destructor
|
||||
"WSABUF" malloc-object dup free-always
|
||||
dup rot set-WSASendTo-args-lpBuffers*
|
||||
swap [ malloc-byte-array dup [ free ] t add-destructor ] keep length
|
||||
swap [ malloc-byte-array dup free-always ] keep length
|
||||
rot [ set-WSABUF-len ] keep
|
||||
set-WSABUF-buf
|
||||
] keep
|
||||
|
|
|
@ -48,7 +48,7 @@ M: win32-file init-handle ( handle -- ) drop ;
|
|||
: open-file ( path access-mode create-mode -- handle )
|
||||
[
|
||||
>r share-mode f r> CreateFile-flags f CreateFile
|
||||
dup invalid-handle? dup [ CloseHandle drop ] f add-destructor
|
||||
dup invalid-handle? dup close-later
|
||||
dup add-completion
|
||||
] with-destructors ;
|
||||
|
||||
|
@ -168,7 +168,7 @@ USE: windows.winsock
|
|||
|
||||
: server-fd ( addrspec type -- fd )
|
||||
>r dup protocol-family r> open-socket
|
||||
dup [ closesocket drop ] f add-destructor
|
||||
dup close-socket-later
|
||||
dup rot make-sockaddr heap-size bind socket-error ;
|
||||
|
||||
USE: namespaces
|
||||
|
|
Loading…
Reference in New Issue