Overhaul monitors
slava
parent
a2c0df8a05
commit
56892ae74a
|
|
@ -90,7 +90,11 @@ ABOUT: "continuations"
|
|||
|
||||
HELP: dispose
|
||||
{ $values { "object" "a disposable object" } }
|
||||
{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
|
||||
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
|
||||
$nl
|
||||
"No further operations can be performed on a disposable object after this call."
|
||||
$nl
|
||||
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." }
|
||||
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
|
||||
|
||||
HELP: with-disposal
|
||||
|
|
|
|||
|
|
@ -112,8 +112,7 @@ ARTICLE: "io.files" "Basic file operations"
|
|||
{ $subsection "file-streams" }
|
||||
{ $subsection "fs-meta" }
|
||||
{ $subsection "directories" }
|
||||
{ $subsection "delete-move-copy" }
|
||||
{ $see-also "os" } ;
|
||||
{ $subsection "delete-move-copy" } ;
|
||||
|
||||
ABOUT: "io.files"
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
IN: threads
|
||||
USING: arrays hashtables heaps kernel kernel.private math
|
||||
namespaces sequences vectors continuations continuations.private
|
||||
dlists assocs system combinators init boxes ;
|
||||
dlists assocs system combinators init boxes accessors ;
|
||||
|
||||
SYMBOL: initial-thread
|
||||
|
||||
|
|
@ -18,11 +18,10 @@ mailbox variables sleep-entry ;
|
|||
|
||||
! Thread-local storage
|
||||
: tnamespace ( -- assoc )
|
||||
self dup thread-variables
|
||||
[ ] [ H{ } clone dup rot set-thread-variables ] ?if ;
|
||||
self variables>> [ H{ } clone dup self (>>variables) ] unless* ;
|
||||
|
||||
: tget ( key -- value )
|
||||
self thread-variables at ;
|
||||
self variables>> at ;
|
||||
|
||||
: tset ( value key -- )
|
||||
tnamespace set-at ;
|
||||
|
|
@ -35,7 +34,7 @@ mailbox variables sleep-entry ;
|
|||
: thread ( id -- thread ) threads at ;
|
||||
|
||||
: thread-registered? ( thread -- ? )
|
||||
thread-id threads key? ;
|
||||
id>> threads key? ;
|
||||
|
||||
: check-unregistered
|
||||
dup thread-registered?
|
||||
|
|
@ -48,38 +47,37 @@ mailbox variables sleep-entry ;
|
|||
<PRIVATE
|
||||
|
||||
: register-thread ( thread -- )
|
||||
check-unregistered dup thread-id threads set-at ;
|
||||
check-unregistered dup id>> threads set-at ;
|
||||
|
||||
: unregister-thread ( thread -- )
|
||||
check-registered thread-id threads delete-at ;
|
||||
check-registered id>> threads delete-at ;
|
||||
|
||||
: set-self ( thread -- ) 40 setenv ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <thread> ( quot name -- thread )
|
||||
\ thread counter <box> [ ] {
|
||||
set-thread-quot
|
||||
set-thread-name
|
||||
set-thread-id
|
||||
set-thread-continuation
|
||||
set-thread-exit-handler
|
||||
} \ thread construct ;
|
||||
\ thread construct-empty
|
||||
swap >>name
|
||||
swap >>quot
|
||||
\ thread counter >>id
|
||||
<box> >>continuation
|
||||
[ ] >>exit-handler ;
|
||||
|
||||
: run-queue 42 getenv ;
|
||||
|
||||
: sleep-queue 43 getenv ;
|
||||
|
||||
: resume ( thread -- )
|
||||
f over set-thread-state
|
||||
f >>state
|
||||
check-registered run-queue push-front ;
|
||||
|
||||
: resume-now ( thread -- )
|
||||
f over set-thread-state
|
||||
f >>state
|
||||
check-registered run-queue push-back ;
|
||||
|
||||
: resume-with ( obj thread -- )
|
||||
f over set-thread-state
|
||||
f >>state
|
||||
check-registered 2array run-queue push-front ;
|
||||
|
||||
: sleep-time ( -- ms/f )
|
||||
|
|
@ -93,14 +91,14 @@ PRIVATE>
|
|||
|
||||
: schedule-sleep ( thread ms -- )
|
||||
>r check-registered dup r> sleep-queue heap-push*
|
||||
swap set-thread-sleep-entry ;
|
||||
>>sleep-entry drop ;
|
||||
|
||||
: expire-sleep? ( heap -- ? )
|
||||
dup heap-empty?
|
||||
[ drop f ] [ heap-peek nip millis <= ] if ;
|
||||
|
||||
: expire-sleep ( thread -- )
|
||||
f over set-thread-sleep-entry resume ;
|
||||
f >>sleep-entry resume ;
|
||||
|
||||
: expire-sleep-loop ( -- )
|
||||
sleep-queue
|
||||
|
|
@ -123,21 +121,21 @@ PRIVATE>
|
|||
] [
|
||||
pop-back
|
||||
dup array? [ first2 ] [ f swap ] if dup set-self
|
||||
f over set-thread-state
|
||||
thread-continuation box>
|
||||
f >>state
|
||||
continuation>> box>
|
||||
continue-with
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: stop ( -- )
|
||||
self dup thread-exit-handler call
|
||||
self dup exit-handler>> call
|
||||
unregister-thread next ;
|
||||
|
||||
: suspend ( quot state -- obj )
|
||||
[
|
||||
self thread-continuation >box
|
||||
self set-thread-state
|
||||
self continuation>> >box
|
||||
self (>>state)
|
||||
self swap call next
|
||||
] callcc1 2nip ; inline
|
||||
|
||||
|
|
@ -157,9 +155,9 @@ M: real sleep
|
|||
millis + >integer sleep-until ;
|
||||
|
||||
: interrupt ( thread -- )
|
||||
dup thread-state [
|
||||
dup thread-sleep-entry [ sleep-queue heap-delete ] when*
|
||||
f over set-thread-sleep-entry
|
||||
dup state>> [
|
||||
dup sleep-entry>> [ sleep-queue heap-delete ] when*
|
||||
f >>sleep-entry
|
||||
dup resume
|
||||
] when drop ;
|
||||
|
||||
|
|
@ -171,7 +169,7 @@ M: real sleep
|
|||
V{ } set-catchstack
|
||||
{ } set-retainstack
|
||||
>r { } set-datastack r>
|
||||
thread-quot [ call stop ] call-clear
|
||||
quot>> [ call stop ] call-clear
|
||||
] 1 (throw)
|
||||
] "spawn" suspend 2drop ;
|
||||
|
||||
|
|
@ -196,8 +194,8 @@ GENERIC: error-in-thread ( error thread -- )
|
|||
<min-heap> 43 setenv
|
||||
initial-thread global
|
||||
[ drop f "Initial" <thread> ] cache
|
||||
<box> over set-thread-continuation
|
||||
f over set-thread-state
|
||||
<box> >>continuation
|
||||
f >>state
|
||||
dup register-thread
|
||||
set-self ;
|
||||
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ HELP: mailbox-get?
|
|||
|
||||
|
||||
ARTICLE: "concurrency.mailboxes" "Mailboxes"
|
||||
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error."
|
||||
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."
|
||||
{ $subsection mailbox }
|
||||
{ $subsection <mailbox> }
|
||||
"Removing the first element:"
|
||||
|
|
@ -73,3 +73,5 @@ ARTICLE: "concurrency.mailboxes" "Mailboxes"
|
|||
"Testing if a mailbox is empty:"
|
||||
{ $subsection mailbox-empty? }
|
||||
{ $subsection while-mailbox-empty } ;
|
||||
|
||||
ABOUT: "concurrency.mailboxes"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
IN: concurrency.mailboxes.tests
|
||||
USING: concurrency.mailboxes vectors sequences threads
|
||||
tools.test math kernel strings ;
|
||||
USING: concurrency.mailboxes concurrency.count-downs vectors
|
||||
sequences threads tools.test math kernel strings namespaces
|
||||
continuations calendar ;
|
||||
|
||||
[ V{ 1 2 3 } ] [
|
||||
0 <vector>
|
||||
|
|
@ -38,3 +39,37 @@ tools.test math kernel strings ;
|
|||
"junk2" over mailbox-put
|
||||
mailbox-get
|
||||
] unit-test
|
||||
|
||||
<mailbox> "m" set
|
||||
|
||||
1 <count-down> "c" set
|
||||
1 <count-down> "d" set
|
||||
|
||||
[
|
||||
"c" get await
|
||||
[ "m" get mailbox-get drop ]
|
||||
[ drop "d" get count-down ] recover
|
||||
] "Mailbox close test" spawn drop
|
||||
|
||||
[ ] [ "c" get count-down ] unit-test
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
[ ] [ "d" get 5 seconds await-timeout ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
||||
<mailbox> "m" set
|
||||
|
||||
1 <count-down> "c" set
|
||||
1 <count-down> "d" set
|
||||
|
||||
[
|
||||
"c" get await
|
||||
"m" get wait-for-close
|
||||
"d" get count-down
|
||||
] "Mailbox close test" spawn drop
|
||||
|
||||
[ ] [ "c" get count-down ] unit-test
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
[ ] [ "d" get 5 seconds await-timeout ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,41 +3,50 @@
|
|||
IN: concurrency.mailboxes
|
||||
USING: dlists threads sequences continuations
|
||||
namespaces random math quotations words kernel arrays assocs
|
||||
init system concurrency.conditions ;
|
||||
init system concurrency.conditions accessors ;
|
||||
|
||||
TUPLE: mailbox threads data ;
|
||||
TUPLE: mailbox threads data closed ;
|
||||
|
||||
: check-closed ( mailbox -- )
|
||||
closed>> [ "Mailbox closed" throw ] when ; inline
|
||||
|
||||
M: mailbox dispose
|
||||
t >>closed threads>> notify-all ;
|
||||
|
||||
: <mailbox> ( -- mailbox )
|
||||
<dlist> <dlist> mailbox construct-boa ;
|
||||
<dlist> <dlist> f mailbox construct-boa ;
|
||||
|
||||
: mailbox-empty? ( mailbox -- bool )
|
||||
mailbox-data dlist-empty? ;
|
||||
data>> dlist-empty? ;
|
||||
|
||||
: mailbox-put ( obj mailbox -- )
|
||||
[ mailbox-data push-front ] keep
|
||||
mailbox-threads notify-all yield ;
|
||||
[ data>> push-front ]
|
||||
[ threads>> notify-all ] bi yield ;
|
||||
|
||||
: wait-for-mailbox ( mailbox timeout -- )
|
||||
>r threads>> r> "mailbox" wait ;
|
||||
|
||||
: block-unless-pred ( mailbox timeout pred -- )
|
||||
pick mailbox-data over dlist-contains? [
|
||||
pick check-closed
|
||||
pick data>> over dlist-contains? [
|
||||
3drop
|
||||
] [
|
||||
>r over mailbox-threads over "mailbox" wait r>
|
||||
block-unless-pred
|
||||
>r 2dup wait-for-mailbox r> block-unless-pred
|
||||
] if ; inline
|
||||
|
||||
: block-if-empty ( mailbox timeout -- mailbox )
|
||||
over check-closed
|
||||
over mailbox-empty? [
|
||||
over mailbox-threads over "mailbox" wait
|
||||
block-if-empty
|
||||
2dup wait-for-mailbox block-if-empty
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: mailbox-peek ( mailbox -- obj )
|
||||
mailbox-data peek-back ;
|
||||
data>> peek-back ;
|
||||
|
||||
: mailbox-get-timeout ( mailbox timeout -- obj )
|
||||
block-if-empty mailbox-data pop-back ;
|
||||
block-if-empty data>> pop-back ;
|
||||
|
||||
: mailbox-get ( mailbox -- obj )
|
||||
f mailbox-get-timeout ;
|
||||
|
|
@ -45,7 +54,7 @@ TUPLE: mailbox threads data ;
|
|||
: mailbox-get-all-timeout ( mailbox timeout -- array )
|
||||
block-if-empty
|
||||
[ dup mailbox-empty? ]
|
||||
[ dup mailbox-data pop-back ]
|
||||
[ dup data>> pop-back ]
|
||||
[ ] unfold nip ;
|
||||
|
||||
: mailbox-get-all ( mailbox -- array )
|
||||
|
|
@ -60,11 +69,18 @@ TUPLE: mailbox threads data ;
|
|||
|
||||
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
|
||||
3dup block-unless-pred
|
||||
nip >r mailbox-data r> delete-node-if ; inline
|
||||
nip >r data>> r> delete-node-if ; inline
|
||||
|
||||
: mailbox-get? ( mailbox pred -- obj )
|
||||
f swap mailbox-get-timeout? ; inline
|
||||
|
||||
: wait-for-close-timeout ( mailbox timeout -- )
|
||||
over closed>>
|
||||
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
|
||||
|
||||
: wait-for-close ( mailbox -- )
|
||||
f wait-for-close-timeout ;
|
||||
|
||||
TUPLE: linked-error thread ;
|
||||
|
||||
: <linked-error> ( error thread -- linked )
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ HELP: spawn-linked
|
|||
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
|
||||
{ $see-also spawn } ;
|
||||
|
||||
ARTICLE: { "concurrency" "messaging" } "Mailboxes"
|
||||
ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
|
||||
"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued."
|
||||
$nl
|
||||
"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is."
|
||||
|
|
@ -43,7 +43,8 @@ $nl
|
|||
{ $subsection receive }
|
||||
{ $subsection receive-timeout }
|
||||
{ $subsection receive-if }
|
||||
{ $subsection receive-if-timeout } ;
|
||||
{ $subsection receive-if-timeout }
|
||||
{ $see-also "concurrency.mailboxes" } ;
|
||||
|
||||
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
|
||||
"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
!
|
||||
USING: kernel threads vectors arrays sequences
|
||||
namespaces tools.test continuations dlists strings math words
|
||||
match quotations concurrency.messaging concurrency.mailboxes ;
|
||||
match quotations concurrency.messaging concurrency.mailboxes
|
||||
concurrency.count-downs ;
|
||||
IN: concurrency.messaging.tests
|
||||
|
||||
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
|
||||
|
|
@ -53,3 +54,14 @@ SYMBOL: exit
|
|||
receive
|
||||
exit "counter" get send
|
||||
] unit-test
|
||||
|
||||
! Not yet
|
||||
|
||||
! 1 <count-down> "c" set
|
||||
|
||||
! [
|
||||
! "c" get count-down
|
||||
! receive drop
|
||||
! ] "Bad synchronous send" spawn "t" set
|
||||
|
||||
! [ 3 "t" get send-synchronous ] must-fail
|
||||
|
|
@ -1,58 +1,106 @@
|
|||
IN: io.monitors
|
||||
USING: help.markup help.syntax continuations ;
|
||||
USING: help.markup help.syntax continuations
|
||||
concurrency.mailboxes quotations ;
|
||||
|
||||
HELP: with-monitors
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." }
|
||||
{ $errors "Throws an error if the platform does not support file system change monitors." } ;
|
||||
|
||||
HELP: <monitor>
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } }
|
||||
{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported."
|
||||
$nl
|
||||
"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;
|
||||
{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." }
|
||||
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||
|
||||
HELP: (monitor)
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "mailbox" mailbox } { "monitor" "a new monitor" } }
|
||||
{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }
|
||||
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||
|
||||
HELP: next-change
|
||||
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }
|
||||
{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;
|
||||
{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." }
|
||||
{ $errors "Throws an error if the monitor is closed from another thread." } ;
|
||||
|
||||
HELP: with-monitor
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
|
||||
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ;
|
||||
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." }
|
||||
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||
|
||||
HELP: +add-file+
|
||||
{ $description "Indicates that the file has been added to the directory." } ;
|
||||
{ $description "Indicates that a file has been added to its parent directory." } ;
|
||||
|
||||
HELP: +remove-file+
|
||||
{ $description "Indicates that the file has been removed from the directory." } ;
|
||||
{ $description "Indicates that a file has been removed from its parent directory." } ;
|
||||
|
||||
HELP: +modify-file+
|
||||
{ $description "Indicates that the file contents have changed." } ;
|
||||
{ $description "Indicates that a file's contents have changed." } ;
|
||||
|
||||
HELP: +rename-file+
|
||||
{ $description "Indicates that file has been renamed." } ;
|
||||
HELP: +rename-file-old+
|
||||
{ $description "Indicates that a file has been renamed, and this is the old name." } ;
|
||||
|
||||
HELP: +rename-file-new+
|
||||
{ $description "Indicates that a file has been renamed, and this is the new name." } ;
|
||||
|
||||
ARTICLE: "io.monitors.descriptors" "File system change descriptors"
|
||||
"Change descriptors output by " { $link next-change } ":"
|
||||
{ $subsection +add-file+ }
|
||||
{ $subsection +remove-file+ }
|
||||
{ $subsection +modify-file+ }
|
||||
{ $subsection +rename-file+ }
|
||||
{ $subsection +add-file+ } ;
|
||||
{ $subsection +rename-file-old+ }
|
||||
{ $subsection +rename-file-new+ } ;
|
||||
|
||||
ARTICLE: "io.monitors.platforms" "Monitors on different platforms"
|
||||
"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is platform-specific. User code should not assume either case."
|
||||
{ $heading "Mac OS X" }
|
||||
"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later."
|
||||
$nl
|
||||
{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."
|
||||
$nl
|
||||
"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
|
||||
{ $heading "Windows" }
|
||||
"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows."
|
||||
$nl
|
||||
"Both recursive and non-recursive monitors are directly supported by the operating system."
|
||||
{ $heading "Linux" }
|
||||
"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later."
|
||||
$nl
|
||||
"Since " { $snippet "inotify" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code."
|
||||
$nl
|
||||
"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory."
|
||||
{ $heading "BSD" }
|
||||
"Factor uses " { $snippet "kqueue" } " to implement monitors on BSD."
|
||||
$nl
|
||||
"Since " { $snippet "kqueue" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code."
|
||||
$nl
|
||||
"Because " { $snippet "kqueue" } " requires that a file descriptor is allocated for each directory being monitored, monitoring of large directory hierarchies may exhaust file descriptors or exhibit suboptimal performance. Furthermore, unmounting a subdirectory of a recursively-monitored directory is not possible."
|
||||
{ $heading "Windows CE" }
|
||||
"Windows CE does not support monitors." ;
|
||||
|
||||
ARTICLE: "io.monitors" "File system change monitors"
|
||||
"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."
|
||||
$nl
|
||||
"Monitoring operations must be wrapped in a combinator:"
|
||||
{ $subsection with-monitors }
|
||||
"Creating a file system change monitor and listening for changes:"
|
||||
{ $subsection <monitor> }
|
||||
{ $subsection next-change }
|
||||
"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:"
|
||||
{ $subsection (monitor) }
|
||||
{ $subsection "io.monitors.descriptors" }
|
||||
"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "."
|
||||
$nl
|
||||
"A utility combinator which opens a monitor and cleans it up after:"
|
||||
{ $subsection "io.monitors.platforms" }
|
||||
"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:"
|
||||
{ $subsection with-monitor }
|
||||
"An example which watches the Factor directory for changes:"
|
||||
"Monitors support the " { $link "io.timeouts" } "."
|
||||
$nl
|
||||
"An example which watches a directory for changes:"
|
||||
{ $code
|
||||
"USE: io.monitors"
|
||||
": watch-loop ( monitor -- )"
|
||||
" dup next-change . . nl nl flush watch-loop ;"
|
||||
""
|
||||
"\"\" resource-path f [ watch-loop ] with-monitor"
|
||||
": watch-directory ( path -- )"
|
||||
" [ t [ watch-loop ] with-monitor ] with-monitors"
|
||||
} ;
|
||||
|
||||
ABOUT: "io.monitors"
|
||||
|
|
|
|||
|
|
@ -3,36 +3,89 @@ USING: io.monitors tools.test io.files system sequences
|
|||
continuations namespaces concurrency.count-downs kernel io
|
||||
threads calendar prettyprint ;
|
||||
|
||||
os { winnt macosx linux } member? [
|
||||
[ "monitor-test" temp-file delete-tree ] ignore-errors
|
||||
os wince? [
|
||||
[
|
||||
[ "monitor-test" temp-file delete-tree ] ignore-errors
|
||||
|
||||
[ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test
|
||||
[ ] [ "monitor-test" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
|
||||
[ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "b" set ] unit-test
|
||||
[ ] [ "monitor-test/a1" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "c" set ] unit-test
|
||||
[ ] [ "monitor-test/a2" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"b" get count-down
|
||||
[
|
||||
"m" get next-change drop
|
||||
dup print flush right-trim-separators
|
||||
"xyz" tail? not
|
||||
] [ ] [ ] while
|
||||
"c" get count-down
|
||||
] "Monitor test thread" spawn drop
|
||||
] unit-test
|
||||
[ ] [ "monitor-test/a1" temp-file "monitor-test/a2" temp-file move-file-into ] unit-test
|
||||
|
||||
[ ] [ "b" get await ] unit-test
|
||||
[ t ] [ "monitor-test/a2/a1" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a3.txt" temp-file touch-file ] unit-test
|
||||
|
||||
[ ] [ "c" get 30 seconds await-timeout ] unit-test
|
||||
[ t ] [ "monitor-test/a2/a1/a3.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a4.txt" temp-file touch-file ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a5.txt" temp-file touch-file ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a4.txt" temp-file delete-file ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a5.txt" temp-file "monitor-test/a2/a1/a4.txt" temp-file move-file ] unit-test
|
||||
|
||||
[ "m" get dispose ] must-fail
|
||||
] when
|
||||
[ t ] [ "monitor-test/a2/a1/a4.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
] with-monitors
|
||||
|
||||
|
||||
[
|
||||
[ "monitor-test" temp-file delete-tree ] ignore-errors
|
||||
|
||||
[ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test
|
||||
|
||||
[ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "b" set ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "c1" set ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "c2" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"b" get count-down
|
||||
|
||||
[
|
||||
"m" get next-change drop
|
||||
dup print flush
|
||||
dup parent-directory
|
||||
[ right-trim-separators "xyz" tail? ] either? not
|
||||
] [ ] [ ] while
|
||||
|
||||
"c1" get count-down
|
||||
|
||||
[
|
||||
"m" get next-change drop
|
||||
dup print flush
|
||||
dup parent-directory
|
||||
[ right-trim-separators "yxy" tail? ] either? not
|
||||
] [ ] [ ] while
|
||||
|
||||
"c2" get count-down
|
||||
] "Monitor test thread" spawn drop
|
||||
] unit-test
|
||||
|
||||
[ ] [ "b" get await ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
|
||||
|
||||
[ ] [ "c1" get 5 seconds await-timeout ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test
|
||||
|
||||
[ ] [ "c2" get 5 seconds await-timeout ] unit-test
|
||||
|
||||
! Dispose twice
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
] with-monitors
|
||||
] unless
|
||||
|
|
|
|||
|
|
@ -1,83 +1,49 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend kernel continuations namespaces sequences
|
||||
assocs hashtables sorting arrays threads boxes io.timeouts ;
|
||||
assocs hashtables sorting arrays threads boxes io.timeouts
|
||||
accessors concurrency.mailboxes ;
|
||||
IN: io.monitors
|
||||
|
||||
<PRIVATE
|
||||
HOOK: init-monitors io-backend ( -- )
|
||||
|
||||
TUPLE: monitor queue closed? ;
|
||||
HOOK: dispose-monitors io-backend ( -- )
|
||||
|
||||
: check-monitor ( monitor -- )
|
||||
monitor-closed? [ "Monitor closed" throw ] when ;
|
||||
|
||||
: (monitor) ( delegate -- monitor )
|
||||
H{ } clone {
|
||||
set-delegate
|
||||
set-monitor-queue
|
||||
} monitor construct ;
|
||||
|
||||
GENERIC: fill-queue ( monitor -- )
|
||||
|
||||
: changed-file ( changed path -- )
|
||||
namespace [ append ] change-at ;
|
||||
|
||||
: dequeue-change ( assoc -- path changes )
|
||||
delete-any prune natural-sort >array ;
|
||||
|
||||
M: monitor dispose
|
||||
dup check-monitor
|
||||
t over set-monitor-closed?
|
||||
delegate dispose ;
|
||||
|
||||
! Simple monitor; used on Linux and Mac OS X. On Windows,
|
||||
! monitors are full-fledged ports.
|
||||
TUPLE: simple-monitor handle callback timeout ;
|
||||
|
||||
M: simple-monitor timeout simple-monitor-timeout ;
|
||||
|
||||
M: simple-monitor set-timeout set-simple-monitor-timeout ;
|
||||
|
||||
: <simple-monitor> ( handle -- simple-monitor )
|
||||
f (monitor) <box> {
|
||||
set-simple-monitor-handle
|
||||
set-delegate
|
||||
set-simple-monitor-callback
|
||||
} simple-monitor construct ;
|
||||
|
||||
: construct-simple-monitor ( handle class -- simple-monitor )
|
||||
>r <simple-monitor> r> construct-delegate ; inline
|
||||
|
||||
: notify-callback ( simple-monitor -- )
|
||||
simple-monitor-callback [ resume ] if-box? ;
|
||||
|
||||
M: simple-monitor timed-out
|
||||
notify-callback ;
|
||||
|
||||
M: simple-monitor fill-queue ( monitor -- )
|
||||
: with-monitors ( quot -- )
|
||||
[
|
||||
[ swap simple-monitor-callback >box ]
|
||||
"monitor" suspend drop
|
||||
] with-timeout
|
||||
check-monitor ;
|
||||
init-monitors
|
||||
[ dispose-monitors ] [ ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
M: simple-monitor dispose ( monitor -- )
|
||||
dup delegate dispose notify-callback ;
|
||||
TUPLE: monitor < identity-tuple path queue timeout ;
|
||||
|
||||
PRIVATE>
|
||||
M: monitor hashcode* path>> hashcode* ;
|
||||
|
||||
HOOK: <monitor> io-backend ( path recursive? -- monitor )
|
||||
M: monitor timeout timeout>> ;
|
||||
|
||||
M: monitor set-timeout (>>timeout) ;
|
||||
|
||||
: construct-monitor ( path mailbox class -- monitor )
|
||||
construct-empty
|
||||
swap >>queue
|
||||
swap >>path ; inline
|
||||
|
||||
: queue-change ( path changes monitor -- )
|
||||
dup [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ;
|
||||
|
||||
HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
|
||||
|
||||
: <monitor> ( path recursive? -- monitor )
|
||||
<mailbox> (monitor) ;
|
||||
|
||||
: next-change ( monitor -- path changed )
|
||||
dup check-monitor
|
||||
dup monitor-queue dup assoc-empty? [
|
||||
drop dup fill-queue next-change
|
||||
] [ nip dequeue-change ] if ;
|
||||
[ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ;
|
||||
|
||||
SYMBOL: +add-file+
|
||||
SYMBOL: +remove-file+
|
||||
SYMBOL: +modify-file+
|
||||
SYMBOL: +rename-file+
|
||||
SYMBOL: +rename-file-old+
|
||||
SYMBOL: +rename-file-new+
|
||||
|
||||
: with-monitor ( path recursive? quot -- )
|
||||
>r <monitor> r> with-disposal ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,59 @@
|
|||
USING: accessors math kernel namespaces continuations
|
||||
io.files io.monitors io.monitors.recursive io.backend
|
||||
concurrency.mailboxes
|
||||
tools.test ;
|
||||
IN: io.monitors.recursive.tests
|
||||
|
||||
\ pump-thread must-infer
|
||||
|
||||
SINGLETON: mock-io-backend
|
||||
|
||||
TUPLE: counter i ;
|
||||
|
||||
SYMBOL: dummy-monitor-created
|
||||
SYMBOL: dummy-monitor-disposed
|
||||
|
||||
TUPLE: dummy-monitor < monitor ;
|
||||
|
||||
M: dummy-monitor dispose
|
||||
drop dummy-monitor-disposed get [ 1+ ] change-i drop ;
|
||||
|
||||
M: mock-io-backend (monitor)
|
||||
nip
|
||||
over exists? [
|
||||
dummy-monitor construct-monitor
|
||||
dummy-monitor-created get [ 1+ ] change-i drop
|
||||
] [
|
||||
"Does not exist" throw
|
||||
] if ;
|
||||
|
||||
M: mock-io-backend link-info
|
||||
global [ link-info ] bind ;
|
||||
|
||||
[ ] [ 0 counter construct-boa dummy-monitor-created set ] unit-test
|
||||
[ ] [ 0 counter construct-boa dummy-monitor-disposed set ] unit-test
|
||||
|
||||
[ ] [
|
||||
mock-io-backend io-backend [
|
||||
"" resource-path <mailbox> <recursive-monitor> dispose
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[ t ] [ dummy-monitor-created get i>> 0 > ] unit-test
|
||||
|
||||
[ t ] [ dummy-monitor-created get i>> dummy-monitor-disposed get i>> = ] unit-test
|
||||
|
||||
[ "doesnotexist" temp-file delete-tree ] ignore-errors
|
||||
|
||||
[
|
||||
mock-io-backend io-backend [
|
||||
"doesnotexist" temp-file <mailbox> <recursive-monitor> dispose
|
||||
] with-variable
|
||||
] must-fail
|
||||
|
||||
[ ] [
|
||||
mock-io-backend io-backend [
|
||||
"" resource-path <mailbox> <recursive-monitor>
|
||||
[ dispose ] [ dispose ] bi
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors sequences assocs arrays continuations combinators kernel
|
||||
threads concurrency.messaging concurrency.mailboxes
|
||||
concurrency.promises
|
||||
io.files io.monitors ;
|
||||
IN: io.monitors.recursive
|
||||
|
||||
! Simulate recursive monitors on platforms that don't have them
|
||||
|
||||
TUPLE: recursive-monitor < monitor children thread ready ;
|
||||
|
||||
DEFER: add-child-monitor
|
||||
|
||||
: qualify-path ( path -- path' )
|
||||
monitor tget path>> prepend-path ;
|
||||
|
||||
: add-child-monitors ( path -- )
|
||||
#! We yield since this directory scan might take a while.
|
||||
[
|
||||
directory* [ first add-child-monitor yield ] each
|
||||
] curry ignore-errors ;
|
||||
|
||||
: add-child-monitor ( path -- )
|
||||
qualify-path dup link-info type>> +directory+ eq? [
|
||||
[ add-child-monitors ]
|
||||
[
|
||||
[ f my-mailbox (monitor) ] keep
|
||||
monitor tget children>> set-at
|
||||
] bi
|
||||
] [ drop ] if ;
|
||||
|
||||
USE: io
|
||||
USE: prettyprint
|
||||
|
||||
: remove-child-monitor ( monitor -- )
|
||||
monitor tget children>> delete-at*
|
||||
[ dispose ] [ drop ] if ;
|
||||
|
||||
M: recursive-monitor dispose
|
||||
dup queue>> closed>> [
|
||||
drop
|
||||
] [
|
||||
[ "stop" swap thread>> send-synchronous drop ]
|
||||
[ queue>> dispose ] bi
|
||||
] if ;
|
||||
|
||||
: stop-pump ( -- )
|
||||
monitor tget children>> [ nip dispose ] assoc-each ;
|
||||
|
||||
: pump-step ( msg -- )
|
||||
first3 path>> swap >r prepend-path r> monitor tget 3array
|
||||
monitor tget queue>>
|
||||
mailbox-put ;
|
||||
|
||||
: child-added ( path monitor -- )
|
||||
path>> prepend-path add-child-monitor ;
|
||||
|
||||
: child-removed ( path monitor -- )
|
||||
path>> prepend-path remove-child-monitor ;
|
||||
|
||||
: update-hierarchy ( msg -- )
|
||||
first3 swap [
|
||||
{
|
||||
{ +add-file+ [ child-added ] }
|
||||
{ +remove-file+ [ child-removed ] }
|
||||
{ +rename-file-old+ [ child-removed ] }
|
||||
{ +rename-file-new+ [ child-added ] }
|
||||
[ 3drop ]
|
||||
} case
|
||||
] with with each ;
|
||||
|
||||
: pump-loop ( -- )
|
||||
receive dup synchronous? [
|
||||
>r stop-pump t r> reply-synchronous
|
||||
] [
|
||||
[ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi
|
||||
pump-loop
|
||||
] if ;
|
||||
|
||||
: monitor-ready ( error/t -- )
|
||||
monitor tget ready>> fulfill ;
|
||||
|
||||
: pump-thread ( monitor -- )
|
||||
monitor tset
|
||||
[ "" add-child-monitor t monitor-ready ]
|
||||
[ [ self <linked-error> monitor-ready ] keep rethrow ]
|
||||
recover
|
||||
pump-loop ;
|
||||
|
||||
: start-pump-thread ( monitor -- )
|
||||
dup [ pump-thread ] curry
|
||||
"Recursive monitor pump" spawn
|
||||
>>thread drop ;
|
||||
|
||||
: wait-for-ready ( monitor -- )
|
||||
ready>> ?promise ?linked drop ;
|
||||
|
||||
: <recursive-monitor> ( path mailbox -- monitor )
|
||||
>r (normalize-path) r>
|
||||
recursive-monitor construct-monitor
|
||||
H{ } clone >>children
|
||||
<promise> >>ready
|
||||
dup start-pump-thread
|
||||
dup wait-for-ready ;
|
||||
|
|
@ -18,13 +18,13 @@ HELP: with-timeout
|
|||
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;
|
||||
|
||||
ARTICLE: "io.timeouts" "I/O timeout protocol"
|
||||
"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
|
||||
"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
|
||||
{ $subsection timeout }
|
||||
{ $subsection set-timeout }
|
||||
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
|
||||
{ $subsection timed-out }
|
||||
"A combinator to be used in operations which can time out:"
|
||||
{ $subsection with-timeout }
|
||||
{ $see-also "stream-protocol" "io.launcher" } ;
|
||||
{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ;
|
||||
|
||||
ABOUT: "io.timeouts"
|
||||
|
|
|
|||
|
|
@ -1,125 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io.backend io.monitors io.monitors.private
|
||||
io.files io.buffers io.nonblocking io.timeouts io.unix.backend
|
||||
io.unix.select io.unix.launcher unix.linux.inotify assocs
|
||||
namespaces threads continuations init math alien.c-types alien
|
||||
vocabs.loader accessors system ;
|
||||
USING: kernel io.backend io.monitors io.unix.backend
|
||||
io.unix.select io.unix.linux.monitors system namespaces ;
|
||||
IN: io.unix.linux
|
||||
|
||||
TUPLE: linux-monitor ;
|
||||
|
||||
: <linux-monitor> ( wd -- monitor )
|
||||
linux-monitor construct-simple-monitor ;
|
||||
|
||||
TUPLE: inotify watches ;
|
||||
|
||||
: watches ( -- assoc ) inotify get-global watches>> ;
|
||||
|
||||
: wd>monitor ( wd -- monitor ) watches at ;
|
||||
|
||||
: <inotify> ( -- port/f )
|
||||
H{ } clone
|
||||
inotify_init dup 0 < [ 2drop f ] [
|
||||
inotify <buffered-port>
|
||||
{ set-inotify-watches set-delegate } inotify construct
|
||||
] if ;
|
||||
|
||||
: inotify-fd inotify get-global handle>> ;
|
||||
|
||||
: (add-watch) ( path mask -- wd )
|
||||
inotify-fd -rot inotify_add_watch dup io-error ;
|
||||
|
||||
: check-existing ( wd -- )
|
||||
watches key? [
|
||||
"Cannot open multiple monitors for the same file" throw
|
||||
] when ;
|
||||
|
||||
: add-watch ( path mask -- monitor )
|
||||
(add-watch) dup check-existing
|
||||
[ <linux-monitor> dup ] keep watches set-at ;
|
||||
|
||||
: remove-watch ( monitor -- )
|
||||
dup simple-monitor-handle watches delete-at
|
||||
simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ;
|
||||
|
||||
: check-inotify
|
||||
inotify get [
|
||||
"inotify is not supported by this Linux release" throw
|
||||
] unless ;
|
||||
|
||||
M: linux <monitor> ( path recursive? -- monitor )
|
||||
check-inotify
|
||||
drop IN_CHANGE_EVENTS add-watch ;
|
||||
|
||||
M: linux-monitor dispose ( monitor -- )
|
||||
dup delegate dispose remove-watch ;
|
||||
|
||||
: ?flag ( n mask symbol -- n )
|
||||
pick rot bitand 0 > [ , ] [ drop ] if ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
IN_CREATE +add-file+ ?flag
|
||||
IN_DELETE +remove-file+ ?flag
|
||||
IN_DELETE_SELF +remove-file+ ?flag
|
||||
IN_MODIFY +modify-file+ ?flag
|
||||
IN_ATTRIB +modify-file+ ?flag
|
||||
IN_MOVED_FROM +rename-file+ ?flag
|
||||
IN_MOVED_TO +rename-file+ ?flag
|
||||
IN_MOVE_SELF +rename-file+ ?flag
|
||||
drop
|
||||
] { } make ;
|
||||
|
||||
: parse-file-notify ( buffer -- changed path )
|
||||
{ inotify-event-name inotify-event-mask } get-slots
|
||||
parse-action swap alien>char-string ;
|
||||
|
||||
: events-exhausted? ( i buffer -- ? )
|
||||
fill>> >= ;
|
||||
|
||||
: inotify-event@ ( i buffer -- alien )
|
||||
ptr>> <displaced-alien> ;
|
||||
|
||||
: next-event ( i buffer -- i buffer )
|
||||
2dup inotify-event@
|
||||
inotify-event-len "inotify-event" heap-size +
|
||||
swap >r + r> ;
|
||||
|
||||
: parse-file-notifications ( i buffer -- )
|
||||
2dup events-exhausted? [ 2drop ] [
|
||||
2dup inotify-event@ dup inotify-event-wd wd>monitor [
|
||||
monitor-queue [
|
||||
parse-file-notify changed-file
|
||||
] bind
|
||||
] keep notify-callback
|
||||
next-event parse-file-notifications
|
||||
] if ;
|
||||
|
||||
: read-notifications ( port -- )
|
||||
dup refill drop
|
||||
0 over parse-file-notifications
|
||||
0 swap buffer-reset ;
|
||||
|
||||
TUPLE: inotify-task ;
|
||||
|
||||
: <inotify-task> ( port -- task )
|
||||
f inotify-task <input-task> ;
|
||||
|
||||
: init-inotify ( mx -- )
|
||||
<inotify> dup [
|
||||
dup inotify set-global
|
||||
<inotify-task> swap register-io-task
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
M: inotify-task do-io-task ( task -- )
|
||||
io-task-port read-notifications f ;
|
||||
|
||||
M: linux init-io ( -- )
|
||||
<select-mx>
|
||||
[ mx set-global ]
|
||||
[ init-inotify ] bi ;
|
||||
<select-mx> mx set-global ;
|
||||
|
||||
linux set-io-backend
|
||||
|
|
|
|||
|
|
@ -0,0 +1,129 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io.backend io.monitors io.monitors.recursive
|
||||
io.files io.buffers io.monitors io.nonblocking io.timeouts
|
||||
io.unix.backend io.unix.select unix.linux.inotify assocs
|
||||
namespaces threads continuations init math math.bitfields
|
||||
alien.c-types alien vocabs.loader accessors system ;
|
||||
IN: io.unix.linux.monitors
|
||||
|
||||
TUPLE: linux-monitor < monitor wd ;
|
||||
|
||||
: <linux-monitor> ( wd path mailbox -- monitor )
|
||||
linux-monitor construct-monitor
|
||||
swap >>wd ;
|
||||
|
||||
SYMBOL: watches
|
||||
|
||||
SYMBOL: inotify
|
||||
|
||||
: wd>monitor ( wd -- monitor ) watches get at ;
|
||||
|
||||
: <inotify> ( -- port/f )
|
||||
inotify_init dup 0 < [ drop f ] [ <reader> ] if ;
|
||||
|
||||
: inotify-fd inotify get handle>> ;
|
||||
|
||||
: check-existing ( wd -- )
|
||||
watches get key? [
|
||||
"Cannot open multiple monitors for the same file" throw
|
||||
] when ;
|
||||
|
||||
: (add-watch) ( path mask -- wd )
|
||||
inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
|
||||
|
||||
: add-watch ( path mask mailbox -- monitor )
|
||||
>r
|
||||
>r (normalize-path) r>
|
||||
[ (add-watch) ] [ drop ] 2bi r>
|
||||
<linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
|
||||
|
||||
: check-inotify
|
||||
inotify get [
|
||||
"Calling <monitor> outside with-monitors" throw
|
||||
] unless ;
|
||||
|
||||
M: linux (monitor) ( path recursive? mailbox -- monitor )
|
||||
swap [
|
||||
<recursive-monitor>
|
||||
] [
|
||||
check-inotify
|
||||
IN_CHANGE_EVENTS swap add-watch
|
||||
] if ;
|
||||
|
||||
M: linux-monitor dispose ( monitor -- )
|
||||
[ wd>> watches get delete-at ]
|
||||
[ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ;
|
||||
|
||||
: ?flag ( n mask symbol -- n )
|
||||
pick rot bitand 0 > [ , ] [ drop ] if ;
|
||||
|
||||
: ignore-flags? ( mask -- ? )
|
||||
{
|
||||
IN_DELETE_SELF
|
||||
IN_MOVE_SELF
|
||||
IN_UNMOUNT
|
||||
IN_Q_OVERFLOW
|
||||
IN_IGNORED
|
||||
} flags bitand 0 > ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
IN_CREATE +add-file+ ?flag
|
||||
IN_DELETE +remove-file+ ?flag
|
||||
IN_MODIFY +modify-file+ ?flag
|
||||
IN_ATTRIB +modify-file+ ?flag
|
||||
IN_MOVED_FROM +rename-file-old+ ?flag
|
||||
IN_MOVED_TO +rename-file-new+ ?flag
|
||||
drop
|
||||
] { } make ;
|
||||
|
||||
: parse-file-notify ( buffer -- path changed )
|
||||
dup inotify-event-mask ignore-flags? [
|
||||
drop f f
|
||||
] [
|
||||
[ inotify-event-name alien>char-string ]
|
||||
[ inotify-event-mask parse-action ] bi
|
||||
] if ;
|
||||
|
||||
: events-exhausted? ( i buffer -- ? )
|
||||
fill>> >= ;
|
||||
|
||||
: inotify-event@ ( i buffer -- alien )
|
||||
ptr>> <displaced-alien> ;
|
||||
|
||||
: next-event ( i buffer -- i buffer )
|
||||
2dup inotify-event@
|
||||
inotify-event-len "inotify-event" heap-size +
|
||||
swap >r + r> ;
|
||||
|
||||
: parse-file-notifications ( i buffer -- )
|
||||
2dup events-exhausted? [ 2drop ] [
|
||||
2dup inotify-event@ dup inotify-event-wd wd>monitor
|
||||
>r parse-file-notify r> queue-change
|
||||
next-event parse-file-notifications
|
||||
] if ;
|
||||
|
||||
: inotify-read-loop ( port -- )
|
||||
dup wait-to-read1
|
||||
0 over parse-file-notifications
|
||||
0 over buffer-reset
|
||||
inotify-read-loop ;
|
||||
|
||||
: inotify-read-thread ( port -- )
|
||||
[ inotify-read-loop ] curry ignore-errors ;
|
||||
|
||||
M: linux init-monitors
|
||||
H{ } clone watches set
|
||||
<inotify> [
|
||||
[ inotify set ]
|
||||
[
|
||||
[ inotify-read-thread ] curry
|
||||
"Linux monitor thread" spawn drop
|
||||
] bi
|
||||
] [
|
||||
"Linux kernel version is too old" throw
|
||||
] if* ;
|
||||
|
||||
M: linux dispose-monitors
|
||||
inotify get dispose ;
|
||||
|
|
@ -1,23 +1,22 @@
|
|||
USING: io.unix.bsd io.backend io.monitors io.monitors.private
|
||||
continuations kernel core-foundation.fsevents sequences
|
||||
namespaces arrays system ;
|
||||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents
|
||||
continuations kernel sequences namespaces arrays system locals ;
|
||||
IN: io.unix.macosx
|
||||
|
||||
macosx set-io-backend
|
||||
|
||||
TUPLE: macosx-monitor ;
|
||||
TUPLE: macosx-monitor < monitor handle ;
|
||||
|
||||
: enqueue-notifications ( triples monitor -- )
|
||||
tuck monitor-queue
|
||||
[ [ first { +modify-file+ } swap changed-file ] each ] bind
|
||||
notify-callback ;
|
||||
|
||||
M: macosx <monitor>
|
||||
drop
|
||||
f macosx-monitor construct-simple-monitor
|
||||
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
|
||||
path mailbox macosx-monitor construct-monitor
|
||||
dup [ enqueue-notifications ] curry
|
||||
rot 1array 0 0 <event-stream>
|
||||
over set-simple-monitor-handle ;
|
||||
path 1array 0 0 <event-stream> >>handle ;
|
||||
|
||||
M: macosx-monitor dispose
|
||||
dup simple-monitor-handle dispose delegate dispose ;
|
||||
handle>> dispose ;
|
||||
|
|
|
|||
|
|
@ -29,7 +29,6 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
[ handle-fd ] 2curry assoc-each ;
|
||||
|
||||
: init-fdset ( tasks fdset -- )
|
||||
! dup clear-bits
|
||||
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
||||
|
||||
: read-fdset/tasks
|
||||
|
|
@ -45,9 +44,9 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
[ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
|
||||
|
||||
: init-fdsets ( mx -- nfds read write except )
|
||||
[ num-fds ] keep
|
||||
[ read-fdset/tasks tuck init-fdset ] keep
|
||||
write-fdset/tasks tuck init-fdset
|
||||
[ num-fds ]
|
||||
[ read-fdset/tasks tuck init-fdset ]
|
||||
[ write-fdset/tasks tuck init-fdset ] tri
|
||||
f ;
|
||||
|
||||
M: select-mx wait-for-events ( ms mx -- )
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ heaps.private system math math.parser ;
|
|||
: threads. ( -- )
|
||||
standard-table-style [
|
||||
[
|
||||
{ "ID" "Name" "Waiting on" "Remaining sleep" }
|
||||
{ "ID:" "Name:" "Waiting on:" "Remaining sleep:" }
|
||||
[ [ write ] with-cell ] each
|
||||
] with-row
|
||||
|
||||
|
|
|
|||
|
|
@ -22,22 +22,29 @@ IN: tools.vocabs.monitor
|
|||
: path>vocab ( path -- vocab )
|
||||
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
|
||||
|
||||
: monitor-thread ( monitor -- )
|
||||
: monitor-loop ( monitor -- )
|
||||
#! On OS X, monitors give us the full path, so we chop it
|
||||
#! off if its there.
|
||||
next-change drop path>vocab changed-vocab reset-cache ;
|
||||
dup next-change drop path>vocab changed-vocab
|
||||
reset-cache
|
||||
monitor-loop ;
|
||||
|
||||
: monitor-thread ( -- )
|
||||
[
|
||||
[
|
||||
"" resource-path t <monitor>
|
||||
|
||||
H{ } clone changed-vocabs set-global
|
||||
vocabs [ changed-vocab ] each
|
||||
|
||||
monitor-loop
|
||||
] with-monitors
|
||||
] ignore-errors ;
|
||||
|
||||
: start-monitor-thread ( -- )
|
||||
#! Silently ignore errors during monitor creation since
|
||||
#! monitors are not supported on all platforms.
|
||||
[
|
||||
"" resource-path t <monitor> [ monitor-thread t ] curry
|
||||
"Vocabulary monitor" spawn-server drop
|
||||
|
||||
H{ } clone changed-vocabs set-global
|
||||
|
||||
vocabs [ changed-vocab ] each
|
||||
] ignore-errors ;
|
||||
[ monitor-thread ] "Vocabulary monitor" spawn drop ;
|
||||
|
||||
[
|
||||
"-no-monitors" cli-args member? [
|
||||
|
|
|
|||
|
|
@ -4,5 +4,6 @@ USING: tools.test tools.vocabs namespaces continuations ;
|
|||
[ ] [
|
||||
changed-vocabs get-global
|
||||
f changed-vocabs set-global
|
||||
[ t ] [ "kernel" changed-vocab? ] unit-test
|
||||
[ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -85,10 +85,11 @@ SYMBOL: changed-vocabs
|
|||
: unchanged-vocabs ( vocabs -- )
|
||||
[ unchanged-vocab ] each ;
|
||||
|
||||
: changed-vocab? ( vocab -- ? )
|
||||
changed-vocabs get dup [ key? ] [ 2drop t ] if ;
|
||||
|
||||
: filter-changed ( vocabs -- vocabs' )
|
||||
changed-vocabs get [
|
||||
[ key? ] curry subset
|
||||
] when* ;
|
||||
[ changed-vocab? ] subset ;
|
||||
|
||||
SYMBOL: modified-sources
|
||||
SYMBOL: modified-docs
|
||||
|
|
@ -96,7 +97,7 @@ SYMBOL: modified-docs
|
|||
: (to-refresh) ( vocab variable loaded? path -- )
|
||||
dup [
|
||||
swap [
|
||||
pick changed-vocabs get key? [
|
||||
pick changed-vocab? [
|
||||
source-modified? [ get push ] [ 2drop ] if
|
||||
] [ 3drop ] if
|
||||
] [ drop get push ] if
|
||||
|
|
|
|||
Loading…
Reference in New Issue